perm filename PASCAL.BKP[PAS,SYS]2 blob
sn#452530 filedate 1979-07-05 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00038 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 (*$T-,S1500,R120*) (*stanford lots pascal compiler*)
C00014 00003 (*history*)
C00028 00004 (*switches - options*)
C00035 00005 (*naming conventions*)
C00037 00006 (*implementation: what you need and how you do it*)
C00046 00007 (*limitations*)
C00048 00008 (*maintenance information*)
C00054 00009 (* GLOBAL DECLARATIONS. *)
C00064 00010 TYPE
C00082 00011 VAR
C00107 00012 (* INITPROCEDURES. *)
C00173 00013 (* init←compile, putadr, location, initpassgo, error *)
C00181 00014 (*symbol table init: enterid, enterstdtypes, enterstdnames, enterundecl*)
C00207 00015 (*get←directives*)
C00220 00016 (* COMPILE[ newpager, writebuffer, getnextline, finishline, error←with←text, warning*)
C00230 00017 (*insymbol[nextch, skipcomment[options], skip←e←directory*)
C00249 00018 (*searchsection, searchid, skipiferr, iferrskip, errandskip*)
C00254 00019 (* BLOCK[ TYPE CHECKING: constant, getbounds, string, comptypes[checksstring[ismagic]] *)
C00267 00020 (* typedefinition (typE DEFINITION PARSER) *)
C00296 00021 (* PARSING OF DECLARATIONS: labeldeclaration, constantdeclaration, typedeclaration, variabledeclaration *)
C00324 00022 (* BODY[generate←word,insert←address,increment←regc,deposit←constant,macro..,put←pagenumber,put←linenumber,support,alfaconstant*)
C00336 00023 (*closefiles, enterbody, leavebody*)
C00356 00024 (*fetch←basis,get←parameter←address,generate←code,load,store,load←address*)
C00369 00025 (* WRITE←MACHINE←CODE[ AND ITS PARTS. *)
C00410 00026 (* PARTS. ]WRITE←MACHINE←CODE. *)
C00428 00027 (* STATEMENT[ makereal, selector[sublowbound] *)
C00442 00028 (* profuncall[getfilename,getputresetrewrite,readreadln,breakcall,writewriteln,messagecall*)
C00468 00029 (* packunpack, newdispose, firstlast, lowerupperbound *)
C00489 00030 (*minmax,getlinenrcall,pagecall,datecall,timecall,clockcall,cardcall*)
C00497 00031 (*abscall,realtimecall,sqrcall,oddcall,ordcall,chrcall,predsucc,eofeoln,protection,calltocall[getstringaddress],haltcall*)
C00506 00032 (*call←non←standard[compparam,checksstringcalls,charconstant] ]profuncall*)
C00531 00033 (* EXPRESSION[changebool, searchcode, simpleexpression[term[factor]]] *)
C00563 00034 (* assignment[storeglobals[storeword,getnewglobptr]] *)
C00575 00035 (*gotostatement,compoundstatement,ifstatement,casestatement,repeatstatement,whilestatement,forstatement,loopstatement,withstatement*)
C00597 00036 (* ]STATEMENT ]BODY ]BLOCK *)
C00610 00037 (* ]compile,reporttime,jumpto *)
C00626 00038 (* MAIN BODY *)
C00638 ENDMK
C⊗;
(*$T-,S1500,R120*) (*stanford lots pascal compiler*)
(********************************************************************************
*
* (C) COPYRIGHT 1978, 1979
* BOARD OF TRUSTEES
* LELAND STANFORD JUNIOR UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1978, 1979
* ARMANDO R. RODRIGUEZ
* LOTS COMPUTER FACILITY
* STANFORD UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1976,
* H.-H. NAGEL
* INSTITUT FUER INFORMATIK
* DER UNIVERSITAET HAMBURG
* SCHLUETERSTRASSE 70
* 2000 HAMBURG-13
* GERMANY
*
* P A S C A L / P A S S G O
* -----------------------------
*
* ONE-SOURCE, TWO-OBJECT COMPILER FOR PASCAL, PRODUCED AT STANFORD
* UNIVERSITY FROM THE DECSYSTEM-10 PASCAL COMPILER WRITTEN BY
* H. H. NAGEL, UNIVERSITY OF HAMBURG. AUG-1978.
*
* (A) IF THIS SOURCE IS COMPILED WITH THE SWITCH OPTION /VERSION:1,
* THE OBJECT CODE IS A FULL PASCAL COMPILER, AS DESCRIBED
* BY NAGEL, WITH SOME IMPROVEMENTS. WE WILL REFER TO IT
* AS PASCAL, OR THE FULL (F) COMPILER.
* (B) IF IT IS COMPILED WITH THE SWITCH OPTIONS /VERSION:2/NOTTY/NOOUTPUT,
* THE OBJECT CODE IS AN INCORE COMPILE-AND-GO COMPILER
* WITH A MINIMUM OF OPTIONS, WHICH WILL NOT ALLOW FOR
* EXTERNAL PROCEDURES, BUT BESIDES THAT, IT SUPPORTS
* EVERYTHING ELSE THE OTHER COMPILER SUPPORTS.
* WE WILL REFER TO IT AS PASSGO, OR THE INCORE (I) COMPILER.
* (c) version numbers 3 and 4 are local to stanford, for the computer at the
* artificial intelligence laboratory. Version 3 is like version 1,
* and version 4 is like version 2.
*
* TO COMPILE THIS COMPILER YOU NEED THE OBJECT CODE OF CASE (A), (at sail, c3)
* THAT IS, A FULL PASCAL COMPILER WITH SOME ADDITIONS.
********************************************************************************)
(* (* CONTENTS. *)
(*
page 02 (*history
page 03 (*documentation: names and files
page 04 (*limitations
page 05 (*maintenance information
page 06 (* GLOBAL DECLARATIONS.
page 07 TYPE
page 08 VAR
page 09 (* INITPROCEDURES.
page 10 (* init←compile, putadr, location, initpassgo, error, get←directives
page 11 (*symbol table init: enterid, enterstdtypes, enterstdnames, enterundecl
page 12 (*get←directives
page 13 (* COMPILE[ newpager, writebuffer, getnextline, finishline, error←with←text, warning
page 14 (*insymbol[nextch, skipcomment[options], skip←e←directory
page 15 (*searchsection, searchid, skipiferr, iferrskip, errandskip
page 16 (* BLOCK[ TYPE CHECKING: constant, getbounds, string, comptypes[checksstring[ismagic]]
page 17 (* typedefinition (typE DEFINITION PARSER)
page 18 (* PARSING OF DECLARATIONS: labeldeclaration, constantdeclaration, typedeclaration, variabledeclaration
page 19 (* BODY[generate←word,insert←address,increment←regc,deposit←constant,macro..,put←pagenumber,put←linenumber,support,alfaconstant
page 20 (*closefiles, enterbody, leavebody
page 21 (*fetch←basis,get←parameter←address,generate←code,load,store,load←address
page 22 (* WRITE←MACHINE←CODE[ AND ITS PARTS.
page 23 (* PARTS. ]WRITE←MACHINE←CODE.
page 24 (* STATEMENT[ makereal, selector[sublowbound]
page 25 (* profuncall[getfilename,getputresetrewrite,readreadln,breakcall,writewriteln,messagecall
page 26 (* packunpack, newdispose, firstlast, lowerupperbound
page 27 (*minmax,getlinenrcall,pagecall,datecall,timecall,clockcall,cardcall
page 28 (*abscall,realtimecall,sqrcall,oddcall,ordcall,chrcall,predsucc,eofeoln,protection,calltocall[getstringaddress],haltcall
page 29 (*call←non←standard[compparam,checksstringcalls,charconstant] ]profuncall
page 30 (* EXPRESSION[changebool, searchcode, simpleexpression[term[factor]]]
page 31 (* assignment[storeglobals[storeword,getnewglobptr]],
page 32 (*gotostatement,compoundstatement,ifstatement,casestatement,repeatstatement,whilestatement,forstatement,loopstatement,withstatement
page 33 (* ]STATEMENT ]BODY ]BLOCK
page 34 (* ]compile,reporttime,jumpto
page 35 (* MAIN BODY
*)
(*history*)
(********************************************************************************
*
* HISTORY OF PREVIOUS VERSIONS
* ****************************
*
*
* MAR-73 SYNTAX ANALYSIS INCLUDING ERROR HANDLING,
* CHECKS BASED ON DECLARATIONS AND ADDRESS-
* AND CODE-GENERATION FOR A HYPOTHETICAL
* STACK COMPUTER BY URS AMMAN
*
* FACHGRUPPE COMPUTER-WISSENSCHAFTEN
* EIDG. TECHNISCHE HOCHSCHULE
* CH-8006 ZUERICH
*
* DEC-73 CODE-GENERATION FOR DECSYSTEM-10
* BY C.O. GROSSE-LINDEMANN, F.W. LORENZ,
* H.H. NAGEL AND P.J. STIRL /1/
*
* JUL-74 IMPLEMENTATION OF NEW FEATURES BY STUDENTS
* DURING A PRACTICAL PROGRAMMING COURSE /2/
*
* DEC-74 MODIFICATIONS TO GENERATE RELOCATABLE
* LINK-10 OBJECT-CODE BY E. KISICKI
*
* DEC-74 DEBUG SYSTEM /5/
* BY P. PUTFARKEN
*
* APR-76 POST-MORTEM DUMP FACILITY /6/
* BY B. NEBEL AND B. PRETSCHNER
*
* AUG-76 IMPROVEMENTS AND ADAPTATION TO STANDARD-PASCAL
* AND CDC 6000-3.4. PASCAL AS PRESENTED IN
* "PASCAL - USER MANUAL AND REPORT" /3,4,7/
* BY E.KISICKI
*
* NOV-76 FORMAL PROCEDURE/FUNCTION PARAMETERS
* AND CORRECTION OF ERRORS
* BY H. LINDE
*
* INSTITUT FUER INFORMATIK
* SCHLUETERSTRASSE 70
* D-2000 HAMBURG 13
*
* /1/ F.W. LORENZ, P.J. STIRL
* UEBERTRAGUNG EINES PASCAL-COMPILERS AUF DAS DECSYSTEM-10
* DIPLOMARBEIT, IFI, HH, 74
*
* C.O. GROSSE-LINDEMANN, H.H. NAGEL
* POSTLUDE TO A PASCAL-COMPILER BOOTSTRAP
* BERICHT NR. 11, IFI, HH, 74
*
* C.O. GROSSE-LINDEMANN
* WEITERFUEHRENDE ARBEITEN AM PASCAL-COMPILER ZUR
* STEIGERUNG DER BENUTZERFREUNDLICHKEIT
* DIPLOMARBEIT, IFI, HH, 75
*
* /2/ ERWEITERUNG VON SPRACHDEFINITION, COMPILER UND LAUFZEIT-
* UNTERSTUETZUNG BEI PASCAL/ ERGEBNISSE EINES PRAKTIKUMS
* IM INFORMATIK GRUNDSTUDIUM
* STUD. BEITRAEGE BEARBEITET VON H.H. NAGEL
* MITTEILUNGEN NR. 16, IFI, HH, 75
*
* /3/ H.H. NAGEL
* PASCAL FOR DECSYSTEM-10/ EXPERIENCES AND FURTHER PLANS
* MITTEILUNGEN NR. 21, IFI, HH, NOV-75
*
* /4/ KATHLEEN JENSEN, NIKLAUS WIRTH
* PASCAL USER MANUAL AND REPORT
* LECTURE NOTES IN COMPUTER SCIENCE VOL 18
* SPRINGER-VERLAG BERLIN-HEIDELBERG-NEW YORK
*
* /5/ P. PUTFARKEN
* TESTHILFEN FUER PASCAL PROGRAMME
* DIPLOMARBEIT, IFI, HH, 76
*
* /6/ B. NEBEL, B. PRETSCHNER
* ERWEITERUNG DES DECSYSTEM-10 PASCAL COMPILERS UM
* EINE MOEGLICHKEIT ZUR ERZEUGUNG EINES POST-MORTEM DUMP
* MITTEILUNGEN NR. 34 , IFI, HH, JUN-76
*
* /7/ E. KISICKI, H.H. NAGEL
* PASCAL FOR THE DECSYSTEM-10
* MITTEILUNGEN NR. , IFI, HH, NOV-76
*
********************************************************************************)
(********************************************************************************
*
* CHANGES MADE AT LOTS, STANFORD UNIVERSITY:
* N.B. THE LETTER AFTER THE FIX NUMBER MEANS THE FIX AFFECTS
* F - ONLY THE FULL COMPILER, PASCAL
* I - ONLY THE INCORE COMPILER, PASSGO
* B - BOTH.
*
* JAN-78 JOHN HENNESSY.
* (0)B CHANGES NEEDED TO IMPLEMENT AT LOTS.
*
* JUN-78 MAN CHOR KO.
* (1)F MODIFY THE CCL SCANNER (GETFILENAME) TO
* TAKE THE LOCAL STANDARD: SWITCHES IN THE FIRST LINE,
* SECOND LINE FOR A FILE NAME TO BE CALLED AFTER THE COMPILER.
*
* JUL-78 ARMANDO R. RODRIGUEZ. SMALL FIXINGS:
* (2)B AVOID RECURSION ON SCANNING COMMENTS.
* (3)B DON'T TAKE '\' AS A COMMENT END UNLESS STARTED BY '%'.
* (4)B CALL PCROSS AND PASS IT ITS PARAMETERS PROPERLY.
* (5)F USE A BIG VALUE FOR RUNCORE.
* (6)B GIVE PAGE NUMBERS ON TTY.
* (7)B KNOW ABOUT SEVERAL NEW RUNTIMES FROM THE CCL SCANNER.
* (8)B IMPLEMENT THE SWITCH /VERSION:<GOODVERSION>, OPTION
* V<GOODVERSION>, TO ALLOW FOR CONDITIONAL COMPILATION: IF
* A COMMENT IS OPEN WITH %<N> WHERE <N> IS THE SAME DIGIT AS
* <GOODVERSION>, INCLUDE IT.
* (9)B CCL SCANNER: IF A DEVICE NAME IS GIVEN, DON'T
* ASUME THE FILE NAME WAS DEFAULTED.
* (10)B WORK PROPERLY WITH ALL COMPILE-CLASS COMMANDS, INCLUDING DEBUG.
* (11)F WHEN GETTING PARAMETER FILE NAMES FROM TTY, ALLOW
* FOR DEFAULT OF OBJECT AND LIST FILES: DEFAULT TO <SOURCE>.REL AND .LST.
* (12)B RUNTIME CHECK FOR NIL OR ZERO POINTERS.
* (13)B OTHER SMALL FIXINGS: REORDER BODY OF INITPROCEDURES;
* APPROPRIATE MESSAGE ON SEGMENTED FILES; TAKE LOADER TMPCORE
* FILE FROM DEBUG COMMAND PROPERLY; TAKE U- SWITCH PROPERLY;
* CANCEL LOAD IF E+ SWITCH PRESENT; ACCEPT EXTRA SEMICOLONS
* IN CASE, BOTH RECORD AND STATEMENT; ACCEPT NULL VARIANT
* PARTS OF RECORDS; PROMPT TTY INPUT FILES PROPERLY; SEND
* BEL ONLY IF NOT CALLING LOADER; COUNT ERRORS OF THE WHOLE
* FILE IN MULTIPLE-PROGRAM FILES; REWRITE OUTPUT ONLY IF NEEDED.
*
* AUG-78 ARMANDO R. RODRIGUEZ. CREATE PASSGO:
* (14)I OUT-COMMENT THE PASCAL FEATURES THAT ARE NOT PASSGO. (MAINLY SWITCHES.)
* (15)I ADD THE PASSGO VERSION OF THINGS WHICH ARE SIMILAR.
* (16)B (THANKS TO KO) FIX A BUG BY WHICH, WHEN YOU READ OR
* WRITE AN ARRAY ELEMENT SUBSCRIPTED BY A MOD EXPRESSION, THE
* GENERATED CODE WOULD READ/WRITE THE CORRESPONDING DIV EXPRESSION,
* INSTEAD OF THE ARRAY ELEMENT. (SUPPRESSED 9-AUG-78. IT INDUCED ANOTHER BUG.)
* (17)I SUPPRESS EXTERN/FORTRAN PROCEDURES , INITPROCEDURES
* AND LIBRARY CALLS FROM PASSGO.
* (18)I SUPPRESS FILE OBJECT, AND THE "TRIVIAL" LINK ITEMS.
* WRITE THE CODE INTO A LARGE ARRAY.
* (19)I WHEN IT FINDS A CALL TO A RUNTIME, GENERATE CODE
* CONTAINING THE ACTUAL ADDRESS OF IT.
* (20)I MOVE THE FILEBLOCKS BEING GENERATED TO THE START OF
* THE ARRAY OF CODE, SO THAT PASSGO CAN WRITE ON THEM WITHOUT
* DAMAGING ITS OWN DATA AREA.
* (21)I GENERATE CODE TO CALL SETTIME AND TIMEREPORT, AND
* TO LINK PROPERLY TO PCROSS; CALL DEBUG PROPERLY. (TO DO THIS,
* USE THE SAME FILEBLOCKS FOR STANDARD FILES IN PASSGO AND
* IN THE USER PROGRAM.)
* (22)B AVOID GENERATION OF CODE IN THE CASE THAT ANY ERROR
* HAS BEEN DETECTED. (SPEED-UP).
* (23)B TO SIMPLIFY CONSISTENCY, USE THE LIBRARY ROUTINES
* TO REPORT RUNTIME AND FOR GET←DIRECTIVES.
* (24)I IMPLEMENT INITPROCEDURES IN PASSGO: GENERATE NORMAL
* CODE, AND CALL THEM AT THE BEGINNING.
*
* SEP-78 ARMANDO R. RODRIGUEZ.
* (25)B IMPLEMENT A NON-STANDARD STRING PACKAGE. TO
* DISABLE IT, CHANGE THE CONSTANT STRINGPACK TO FALSE.
* (26)I SUPPORT A SWITCH /SHOW TO DISPLAY THE RUNTIME
* MEMORY ORGANIZATION.
*
* MAR-79 ARMANDO R. RODRIGUEZ.
* (27)B SUPPORT MORE NICELY THE SOURCE FILES WITH NO
* LINE NUMBERS: USE PROCEDURE NAME INSTEAD OF PAGE ON ERROR
* MESSAGES, AND PRODUCE A .PRC FILE.
* (28)B (AS IMPLEMENTED BY PHILIP WISOFF) PRODUCE STATEMENT
* COUNTS: INSERT COUNTER INSTRUCTIONS AND DATA AREA, AND A
* CALL TO A COUNT DUMPER, THAT PRODUCES A .KNT FILE, USABLE
* BY PCROSS FROM 10-MAR-79.
* (29)B ADD THE PREDEFINED PROCEDURE SETRAN, AND MAKE CALLS
* TO SQRT PASS THROUGH PSQRT, TO DETECT NEGATIVE NUMBERS.
* (30)B CHANGES IN ERROR MESSAGES: IF THE ERROR OCCURS IN THE
* FIRST TOKEN OF THE LINE, SUGGEST CHECKING THE PREVIOUS LINE.
* ADD A NEW MESSAGE FOR THE CASE WHEN THE GLOBALS NEED MORE
* MEMORY SPACE THAN THE LOWER SEGMENT CAN GIVE.
* (31)F SWITCHES /NOTTY and /NOOUTPUT to tell that external
* procedures don't need those files.
* (32)B MESSAGE would blow when needing last a PASCAL-written runtime.
*
********************************************************************************)
(*switches - options*)
(*******************************************************************************************
*
* <PROGRAM LIBRARY> ::= [<OPTION SEQUENCE>] [<PROGRAM>]*
* <PROGRAM> ::= <PROGRAM HEADING><BLOCK>.
* <PROGRAM HEADING> ::= PROGRAM <PROGRAMNAME>
* [,<ENTRY>]*
* [(<FILE IDENTIFIER>[,<FILE IDENTIFIER>]* )];
* <OPTION SEQUENCE> ::= ( *$ <OPTION>[,<OPTION>]* <ANY COMMENT> * )
* <OPTION> ::= <LETTER><SIGN>
* <LETTER> ::= [D, E, L, P, T, U]
* <SIGN> ::= [+, -]
*
* <PROGRAMNAME> ::= <IDENTIFIER>
* <FILE IDENTIFIER> ::= <IDENTIFIER>
* <ENTRY> ::= <IDENTIFIER>
*
************************************ COMPILER OPTIONS ************************************
*
* DEC-10 PASCAL FUNCTION DEFAULT
*
* [NO]LIST(+) - GENERATE LIST FILE OFF
* [NO]CODE L+/L- LIST OBJECT CODE OFF
* [NO]CHECK T+/T- PERFORM RUNTIME CHECKS ON
* [NO]DEBUG D+/D-, P+/P-($) GENERATE DEBUG INFORMATION
* INCLUDING POST-MORTEM DUMP OFF
* [NO]COMPILE(+) - COMPILE THE FILE ON
* [NO]EXTERN E+/E-(@) ALL LEVEL-1 PROCEDURES
* AND FUNCTIONS MAY BE DE-
* CLARED AS "EXTERN" BY OTHER
* PROGRAMS. THESE ENTRIES MUST
* BE DEFINED IN THE PROGRAM
* HEADING ADDITIONALLY OFF
* [NO]CARD U+/U-(@) ONLY 72 CHARS OF THE SOURCE
* LINE ARE ACCEPTED (CARD FORMAT) OFF
* FORTIO I+/I- ENABLE FORTRAN-I/O IN EXTERNAL
* FORTRAN PROGRAMS OFF
* CODESIZE:N SN MAXIMUM NUMBER OF
* CODE WORDS FOR A BODY CIXMAX
* RUNCORE:N RN SIZE OF LOW-SEGMENT LOW-BREAK
* FILE:N FN THIS OPTION IS
* NECESSARY IF FILES ARE
* DECLARED IN EXTERNAL PROGRAMS.
* N IS THE NUMBER OF FILES
* ALREADY DECLARED IN THE MAIN
* (AND/OR OTHER EXTERNAL)
* PROGRAM(S) PLUS 1 0
* [NO]CREF(+) - GENERATE CROSS REFERENCE LIST OFF
* [NO]LINK - profuncall LINK-10 AFTER COMPILATION OFF
* [NO]EXECUTE - LOAD AND RUN COMPILED PROGRAM OFF
* REGISTER:N XN HIGHEST REGISTER USED
* TO PASS PARAMETERS STDPARREGCMAX
*
* SWITCHES MARKED WITH A (+) ARE ALSO PART OF THE DECSYSTEM-10 CONCISE COMMAND
* LANGUAGE. THE OTHERS MUST BE ENCLOSED IN "()" IF SPECIFIED
* IN A COMPILE-, LOAD-, EXECUTE- OR DEBUG-COMMAND-STRING,
* E.G.: COMPILE PASRL1=PASCAL.PAS(DEBUG/EXTERN)/LIST/COMPILE
*
* SWITCHES MARKED WITH ($) OR (@) MUST BE SPECIFIED FOR THE FIRST TIME BEFORE THE
* <PROGRAM HEADING>. THOSE WITH (@) CANNOT BE RE-DEFINED AGAIN INSIDE A <PROGRAM>,
* THOSE WITH ($) MIGHT BE RE-DEFINED INSIDE A <PROGRAM> OR
* <PROGRAM LIBRARY>. ALL OTHER SWITCHES CAN BE DEFINED AND
* RE-DEFINED ANYWHERE INSIDE A PROGRAM.
*
*******************************************************************************************)
(*naming conventions*)
(********************************************************************************
*
* HINTS TO INTERPRET ABBREVIATIONS
*
* BRACK : BRACKET "[ ]" IX : INDEX
* C : CURRENT L : LOCAL
* C : COUNTER L : LEFT
* CST : CONSTANT PARENT : "( )"
* CTP : IDENTIFIER POINTER P/PTR : POINTER
* EL : ELEMENT P/PROC : PROCEDURE
* F : FORMAL R : RIGHT
* F : FIRST S : STRING
* F : FILE SY : SYMBOL
* F/FUNC : FUNCTION V : VARIABLE
* G : GLOBAL V : VALUE
* ID : IDENTIFIER BP : BYTEPOINTER
* REL : RELATIVE REL : RELOCATION
*
********************************************************************************)
(*implementation: what you need and how you do it*)
(********************************************************************************
*
* FILES NECESSARY TO IMPLEMENT THE PASCAL COMPILER
* NOTE: THIS LIST HAS BEEN MODIFIED TO FIT LOTS COMPUTER FACILITY
*
* SOURCE-CODE
*
* PASCAL.PAS : PASCAL AND PASSGO COMPILERS
*
* LIBPAS.PAS : CCL (OPTION, GETOPTION, GETFILENAME, GETPARAMETER,
* ASKFILENAME, STARTFILE, GETNEXTCALL, REENTER)
* DDT (DEBUG)
* STATUS (GETSTATUS)
* READ (READIRANGE, READCRANGE, READRRANGE, READSCALAR,
* READISET, READCSET, READDSET)
* WRITE (WRTSCALAR, WRTISET, WRTDSET,WRTCSET)
* TIMING (SETRUNTIME, SETELAPSEDTIME, SETTIME,
* RUNTIME, ELAPSEDTIME, TIMEREPORT)
* STRLIB (CREATE, LENGTH, INDEX, SUBSTR, GETCHAR,
* PUTCHAR, COMPSTR, READSTR)
*
* LIBMAC.MAC : MACRO RUNTIME SUPPORT
*
* PCROSS.PAS : CROSS REFERENCE WITHOUT CODE-GENERATION
*
*
* OBJECT-CODE
*
* PASLIB.REL : SEARCH LIBRARY CONTAINING LIBPAS.REL
* AND LIBMAC.REL
*
*
* EXECUTABLE-CODE
*
* PASCAL.EXE : PASCAL EXECUTABLE MODULE
* PCROSS.EXE : PCROSS EXECUTABLE MODULE
* PASSGO.EXE : PASSGO EXECUTABLE MODULE.
*
*
* INFORMATION AND MAINTENANCE
*
* PASCAL.MAN : A GUIDE FOR THE LOTS PASCAL/PASSGO DIALECT
*
*******************************************************************************)
(*******************************************************************************
*
* HOW TO GENERATE A NEW PASCAL COMPILER
* NOTE: THIS INFORMATION HAS BEEN UPDATED TO REFLECT THE
* SITUATION AT LOTS.
*
* 1) CHANGES TO THE RUNTIME-SUPPORT
*
* LET LIBPAS.PAS AND LIBMAC.MAC BE YOUR MODIFIED RUNTIME SUPPORT
*
* @COMPILE LIBMAC.MAC/LIST
* ...
* @COMPILE LIBPAS.PAS/LIST
* PASCAL: LIBPAS [CCL: OPTION, ... ] 1.. 2..
* ...
* PASCAL: LIBPAS [DEBUG: DEBUG] 2.. 3..
* ...
* EXIT
* @RENAME PASLIB.REL PASLIB.OLD
* @MAKLIB at 10 sites: ( $ is <alt mode> )
* *PASLIB=LIBPAS,LIBMAC/APPEND .R FUDGE2
* *PASLIB=PASLIB/INDEX *PASLIB=LIBPAS,LIBMAC/A$
* *PASLIB=PASLIB/POINTS *PASLIB=PASLIB/X$
* *↑C *↑C
* @LOAD PASSGO (* BECAUSE PASLIB IS PART OF
* @SAVE PASSGO (* PASSGO.EXE
* @PRINT PASLIB.LST
*
*
* 2) CHANGES TO THE COMPILER
*
* LET PASCAL.PAS BE YOUR NEW COMPILER SOURCE
* (DO NOT FORGET TO CHANGE THE "HEADER" AND CHECK FOR THE CORRECT
* FILE DESCRIPTIONS FOR PASLIB AND PCROSS IN INITPROCEDURE
* "SEARCH LIBRARIES")
*
* @PASCAL
* OBJECT = P1/EXECUTE
* LIST = <CR>
* SOURCE = PASCAL/VERSION:1
* PASCAL: P1 [PASCAL] 1..
* 0 ERROR(S) DETECTED
* ...
* LINK: LOADING
* [...P1 EXECUTION]
* OBJECT= P2/EXECUTE
* LIST= <CR>
* SOURCE= PASCAL/VERSION:1
* PASCAL: P2 [PASCAL] 1..
* 0 ERROR(S) DETECTED
* ...
* LINK: LOADING
* [...P2 EXECUTION]
* OBJECT= P3
* LIST= <CR>
* SOURCE= PASCAL/VERSION:1
* PASCAL: P3 [PASCAL] 1..
* 0 ERROR(S) DETECTED
* ...
* EXIT
* @ FILCOM At SAIL: (maybe other 10 sites?)
* *TTY:=P2.REL,P3.REL .R BINCOM
* NO DIFFERENCES ENCOUNTERED P2
* *↑C P3
* @DELETE P1.*,P3.*
* @RENAME P2.* PASCAL
* @RENAME PASCAL.PAS PASCAL.OLD
* @RENAME PASCAL.NEW PASCAL.PAS
* @LOAD PASCAL/MAP
* @SAVE PASCAL
* @START
* OBJECT = PASSGO
* LIST = <CR>
* SOURCE = PASCAL/VERSION:2/NOTTY
* PASCAL: PASSGO [PASSGO] 1..
* 0 ERROR(S) DETECTED
* ...
* EXIT
* @LOAD PASSGO/MAP
* @SAVE PASSGO
* @PCROSS
* OLDSOURCE = PASCAL.PAS
* NEWSOURCE = PASCAL.PAS/VERSION:11/COMM:U
* CROSSLIST = PASCAL.CRL/CROSS:1
* PCROSS: PASCAL [PASCAL] 1..
* 0 ERROR(S) DETECTED
* EXIT
* @PCROSS
* OLDSOURCE = PASCAL.PAS/NONEW
* CROSSLIST = PASC2.CRL/VERSION:1/CROSS:14
* PCROSS: PASCAL [PASCAL] 1..
* 0 ERROR(S) DETECTED
* EXIT
* @PCROSS
* OLDSOURCE = PASCAL.PAS/NONEW
* CROSSLIST = PASSGO.CRL/CROSS:14/VERSION:2
* PCROSS: PASCAL [PASSGO] 1..
* 0 ERROR(S) DETECTED
* EXIT
* @PRINT PASCAL.CRL,PASC2.CRL,PASSGO.CRL/DELETE
*
*
* 3) CHANGES TO PCROSS
*
* @LOAD PCROSS/LIST/COMPILE
* ...
* EXIT
* @SAVE PCROSS
*
********************************************************************************)
(*limitations*)
(*******************************************************************************
*
* KNOWN BUGS AND RESTRICTIONS
*
* 1) IF THE DEVICE-PARAMETER FOR RESET/REWRITE IS NOT
* DEFAULTED, NEW BUFFERS ARE ALLOCATED WITHOUT REGARD
* TO THE FACT THAT THE NEW DEVICE COULD BE THE SAME AS THE
* THE OLD DEVICE.
*
* 2) COMPARISON OF VARIABLES OF TYPE PACKED RECORD OR
* PACKED ARRAY MAY CAUSE TROUBLE IF THESE VARIABLES APPEAR
* IN A VARIANT PART OR WERE ASSIGNED FROM A VARIANT PART
*
* 3) TOO LARGE ARRAY DIMENSIONS (F.E. MININT..MAXINT) CAUSE
* ARITHMETIC OVERFLOW INSTEAD OF AN APPROPRIATE ERROR
* MESSAGE
*
* 4) ARRAYS OF FILE AND RECORDS WITH FILES AS COMPONENTS
* ARE NOT IMPLEMENTED
*
* 5) SEGMENTED FILES ARE NOT IMPLEMENTED
*
* 6) CALL OF EXTERNAL COBOL OR ALGOL PROCEDURES IS
* NOT IMPLEMENTED
*
*
********************************************************************************)
(*maintenance information*)
(********************************************************************************
*
* WHAT TO DO TO ADD PROCEDURES TO THE LIBRARY
* WHEN YOU ADD ANY PROCEDURE OR FUNCTION TO THE LIBRARY, YOU
* NEED TO DO THE FOLLOWING, FOR THE COMPILER TO KNOW ABOUT IT:
*
* 1. A) IF IT IS A PREDECLARED PROCEDURE OR FUNCTION:
* A1. IN INITPROCEDURE (*STANDARD NAMES :
* ADD ITS NAME TO NA[DECLPROC] OR NA[DECLFUNC]
* INCREMENT THE VALUE OF NAMAX[DECLPROC] OR NAMAX[DECLFUNC]
* A2. IN INITPROCEDURE (*PROCEDURE/FUNCTION NAMES :
* ADD THE ENTRYPOINT NAME (THE FIRST SIX CHARACTERS
* OF THE NAME OF THE PROCEDURE OR FUNCTION) TO
* EXTNA[DECLPROC] OR EXTNA[DECLFUNC]. DEFINE THE
* CORRESPONDING ELEMENT OF EXTLANGUAGE ACCORDINGLY.
*
* B) IF IT IS A RUNTIME SUPPORT PROCEDURE:
* B1. ADD A NEW MEMBER TO THE TYPE SUPPORTS, AT THE END
* B2. IN INITPROCEDURE (*RUNTIME-, DEBUG-SUPPORT NAMES :
* AD THE ENTRYPOINT NAME TO RUNTIME←SUPPORT.NAME
* (IF IT IS PART OF THE SUPPORTS FOR READ/WRITE, YOU
* NEED TO ADD AN ELEMENT TO TYPE SCALARFORM, OR CHANGE
* THE BOUNDS OF SUBSCRIPTS OF WRITE←SUPPORT, READ←SUPPORT,
* AND ADD THE CORRESPONDING VALUE FROM SUPPORTS TO
* THE CORRESPONDING ARRAY, IN THIS INITPROCEDURE)
*
* 2. PASSGO NEEDS TO KNOW THEIR LINKAGE ADDRESS, SO YOU NEED TO
* ADD THEIR ENTRYPOINT NAMES TO THE TABLES IN THE MACRO RUNTIME
* SUPORT PUTADR. THE PARAMETERS TO PUTADR ARE :
* EXTADDR[DECLPROC],EXTADDR[DECLFUNC],RUNTIME←SUPPORT.LINK
*
* 3. FOR PREDECLARED PROCEDURES/FUNCTIONS, YOU NEED TO ENTER THEN
* IN THE SYMBOL TABLE. ADD CODE AT THE END OF PROCEDURE
* ENTERSTDNAMES. FOLLOW THE MODEL GIVEN BY THE OTHER PROCEDURES:
* A) CALL ENTERSTDPARAMETER ONCE FOR EACH PARAMETER, STARTING
* WITH THE LAST. THE PARAETERS ARE: TYPE POINTER, FORMAL/ACTUAL
* (I.E., DECLARED AS VAR, YES/NO),A POINTER, EXPECTED
* POSITION. YHE POINTER SHOULD BE NIL IN THE FIRST CALL,
* CP IN ALL THE OTHERS. THE POSITION HAS TO BE FIGURED:
* THE FIRST PARAMETER (THE LAST CALL) GETS 1; FROM THEN ON,
* YOU INCREMENT IT BY THE NUMBER OF WORDS OCCUPIED BY
* EACH PARAMETER: ONE FOR SIMPLE TYPES AND FORMAL PARAMETERS
* AND POINTERS, TWO FOR PACKED ARRAYS OF CHAR OF LENGHT
* 6 TO 10, WHICH ARE ACTUAL PARAMETERS, ETC.
* B) CALL ENTERSTDPROCFUNC. PARAMETERS ARE: THE VALUE OF THE
* SECOND SUBSCRIPT OF ITS NAME IN ARRAY NA, PROC OR FUNC
* ACCORDING TO WHETHER THE FIRST SUBSCRIPT IS DECLPROC OR
* DECLFUNC, TYPE POINTER FOR WHAT IT RETURNS (NIL FOR
* PROCEDURES), AND CP.
*
* 4. IF THEY NEED SPECIAL TREATMENT FOR THE PARAMETER CHECKING,
* THAT IS, IF THEY TAKE DEFAULTS, ACCEPT SEVERAL TYPES FOR
* A GIVEN PARAMETER, OR HAVE OPTIONAL PARAMETERS (LIKE READ
* OR WRITE), YOU HAVE TO MAKE A PROCEDURE TO PARSE THEIR
* PARAMETERS WHEN CALLED. THAT IS DONE BY PROCEDURE CALL,
* INSIDE STATEMENT, AND THE PROCEDURES THAT ARE ALREADY THERE
* SHOULD SERVE YOU WELL AS EXAMPLES OF HOW TO DO IT.
*
********************************************************************************)
(* GLOBAL DECLARATIONS. *)
%13
PROGRAM pascal; (* 14.*) \
%24
PROGRAM passgo; (* 15.*) \
LABEL
0;
CONST
(* NIL = 377777B; *)
(* ALFALENGTH = 10; *)
(* MININT = 400000000000B; *)
(* MAXINT = 377777777777B; *)
(* MAXREAL = 1.7014118432E+38; *)
(* SMALLREAL= 1.4693680107E-39; *)
(* INF = 0; UNLESS STRINGPACK IS FALSE - 25.*)
%1 header = 'PASCAL/LOTS FROM 1-jul-79'; (* 14.*) \
%2 header = 'PASSGO/LOTS FROM 1-jul-79'; (* 15.*) \
%3 header = 'PASCAL/SAIL 1.0 1-jul-79'; \
%4 HEADER = 'PASSGO/SAIL 1.0 1-jul-79'; \
headlen = 11; (*PART OF THE HEADER THAT WIL SHOW UP IN TTY*)
(*COMPILER PARAMETERS:*)
(**********************)
displimit = 20; (* MAXIMUM DECLARATION-SCOPE NESTING *)
%13 max←file = 12; (* MAXIMUM NUMBER OF USER-DECLARED FILES *) (* 14.*) \
max←channel = 15; (* HIGHEST DATA-CHANNEL ASSIGNED TO A FILE *)
maxlevel = 10; (* MAXIMUM PROC/FUNC LEVEL *)
strglgth = 135; (* MAXIMUM LENGTH FOR STRING-CONSTANT *) (* 25. INCREASED FROM 120.*)
xtrastrglgth = 136; (* 25. FOR PARAMETERS TO STRING PROCEDURE CALLS.*)
sizeoffileblock = 21; (* SIZE OF FILE CONTROL-BLOCK *)
cixmax = 1000; (* STANDARD SIZE OF CODE-ARRAY *)
maxerr = 4; (* MAXIMUM OF ERRORS IN 1 SOURCE-LINE *)
labmax = 9999; (* MAXIMUM VALUE OF A PROGRAM LABEL *)
bitmax = 36; (* NR. OF BITS OF 1 DECSYSTEM-10 MACHINE-WORD *)
hwcstmax = 377777B; (* MAXIMUM POS. INTEGER IN HALFWORD *)
entrymax = 20; (* MAXIMUM ENTRIES INTO EXTERN PROGRAM *)
extpfmax = 29; (* MAXIMUM OF EXTERN STANDARD PROC/FUNC *) (* 25. *)
stdmax = 36; (* NR. OF STANDARD NAMES *)
rswmax = 42; (* NR. OF RESERVED WORDS *)
rswmaxp1 = 43; (* RESERVED WORDS PLUS 1 *)
stdchcntmax = 132; (* MAXIMUM OF CHARS IN SOURCE-LINE *)
basemax = 71; (* MAXIMUM VALUE OF A SET ELEMENT *)
offset = 40B; (* USED FOR SETS OF CHARACTERS *)
buffer←size = 200B; (* DECSYSTEM-10 DISK-BUFFER SIZE *)
tagfmax = 5; (* MAX. NR. OF VARIANTS ALLOWED IN CALL OF "NEW" *)
jump←max = 50; (* MAX. NR. OF LABEL DECLARATIONS *)
maxpcrossoption = 20; (* 4. NR. OF OPTION SWITCHES OF PCROSS *)
reg0 = 0; (* WORKREGISTER *)
reg1 = 1; (* WORKREGISTER (USED FOR ARRAY-BYTEPOINTERS) *)
regin = 1; (* TO INITIALIZE REGC *)
stdparregcmax = 6; (* HIGHEST REGISTER USED FOR PARAMETERS *)
within = 12; (* FIRST REGISTER FOR WITH-STACK *)
newreg = 13; (* LAST PLACE OF NEW-STACK *)
basis = 14; (* ADDR OF CURRENT ACTIVATION-REC, STATIC AND DYNAMIC LINK *)
topp = 15; (* FIRST FREE WORD IN DATA-STACK *)
jbrel = 44B; (* LOCATION OF (0,HIGHEST LEGAL LOW-SEG ADDRESS) *)
jbsa = 120B; (* LOCATION OF (1ST UNUSED LOW-SEG ADDRESS,START-ADDRESS OF PROGRAM) *)
(* JBFF = 121B; (* LOCATION OF (0,POINTER BEHIND LAST FILE-BUFFER) *) (* NOT USED.*)
jbapr = 125B; (* LOCATION OF (0,PC AFTER PROGRAM ERROR) *)
jbddt = 74B; (* LOCATION OF (LAST PASDDT-ADDR, PASDDT-ADDR + 2) *)
tty←sixbit = 646471B; (* SIXBIT REPR. FOR 'TTY ' *)
dsk←sixbit = 446353B; (* SIXBIT REPR. FOR 'DSK ' *)
ascii←mode = 0; (* (SYSTEM-) FLAGS FOR ASCII-MODE *)
binary←mode = 14B; (* (SYSTEM-) FLAGS FOR BINARY-MODE *)
text←file = 0; (* (PASCAL-) FLAGS FOR "PACKED FILE OF (SUBRANGE OF) CHAR" = "TEXT" *)
data←file = 1; (* (PASCAL-) FLAGS FOR OTHER FILES *)
debug←save = 0B; (* ADDR OF DEBUG-SYSTEM STACK *)
debug←stop = 1B; (* PUSHJ INTO DEBUG ON "STOP" *)
(* DEBUG←PAGEHEAD = 2B; (* START OF "STOP"-CHAIN *) (* NOT USED.*)
debug←stackbottom = 3B; (* 1ST WORD OF PROGRAM-STACK *)
debug←initialization = 6B; (* PUSHJ INTO DEBUG-INITIALIZATION *)
debug←programname = 7B; (* ADDR OF ADDR OF PROGRAMNAME *)
system←low←start = 140B; (* LOC 0B..137B CONTAIN SYSTEM-INFO. *)
(* SYSTEM←HIGH←START = 400010B; (* LOC 400000B..400007B CONTAIN SYSTEM-INFO. *) (* NOT USED.*)
low←start = 10B; (* LOC 0B..7B RESERVED FOR DEBUG-PROGR. *)
high←start = 400000B; (* START OF EXECUTABLE CODE *)
maxaddr = 777777B; (* HIGHEST LEGAL ADDRESS *)
%13 (* 18. NO LINK←ITEMS IN PASSGO.*)
item←1 = 1; (* LINK ITEM 1: CODE *)
item←2 = 2; (* LINK ITEM 2: SYMBOLS *)
item←3 = 3; (* LINK ITEM 3: HIGHSEG *)
item←4 = 4; (* LINK ITEM 4: ENTRIES *)
item←5 = 5; (* LINK ITEM 5: LOW-/ HIGHSEGMENT BREAK *)
item←6 = 6; (* LINK ITEM 6: PROGRAM NAME *)
item←7 = 7; (* LINK ITEM 7: START ADDRESS *)
item←10 = 10B; (* LINK ITEM 10: INTERNAL REQUESTS *)
item←17 = 17B; (* LINK ITEM 17: LINK LIBRARIES *)
(* 18.*) \
entry←symbol = 0; (* ENTRY SYMBOL FLAG *)
global←symbol = 1; (* GLOBAL SYMBOL FLAG *)
local←symbol = 2; (* LOCAL SYMBOL FLAG *)
sixbit←symbol = 6; (* SIXBIT SYMBOL FLAG *)
extern←symbol = 14B; (* EXTERN SYMBOL FLAG *)
%24 maxfilecode = 1777B; (* 20. SIZE OF MEMORY FOR USER FILE BLOCKS AND STRING CONSTANTS.*)
%24 maxcode = 60000B; (* 20. SIZE OF MEMORY FOR USER PROGRAM AND FILE BLOCKS.*) \
stringpack = true; (* 25. IF FALSE, NON-STANDARD STRING PACKAGE IS DEACTIVATED.*)
TYPE
(* INTEGER = MININT..MAXINT *)
(* REAL = -MAXREAL..MAXREAL *)
(* CHAR = ' '..'←' *)
(* ASCII = NUL..DEL *)
(* BOOLEAN = (FALSE,TRUE) *)
(* TEXT = PACKED FILE OF CHAR *)
(* ALFA = PACKED ARRAY[1..ALFALENGTH] OF CHAR *)
(*DESCRIBING:*)
(*************)
(*BASIC SYMBOLS*)
(***************)
symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
colon,becomes,labelsy,constsy,typesy,varsy,functionsy,
proceduresy,packedsy,setsy,arraysy,recordsy,filesy,forwardsy,
beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,loopsy,
gotosy,exitsy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,
externsy,pascalsy,fortransy,programsy, thensy,othersy,initprocsy,segmentsy,otherssy);
operator = (noop,mul,rdiv,andop,idiv,imod,plus,minus,orop,
ltop,leop,geop,gtop,neop,eqop,inop);
setofsys = SET OF symbol;
(*BASIC RANGE DEFINITIONS*)
(*************************)
levrange = 0..maxlevel;
keyrange = 0..77B;
fileformrange = 0..77B;
filemoderange = 0..77B;
addrrange = 0..maxaddr;
instrange = 0..677B;
radixrange = 0..37777777777B;
flagrange = 0..17B;
bitrange = 0..bitmax;
acrange = 0..15;
ibrange = 0..1;
coderange = 0..hwcstmax;
bits5 = 0..37B;
bits6 = 0..77B;
bits7 = 0..177B;
bits12 = 0..7777B;
bits18 = 0..777777B;
setrange = 0..basemax;
jump←range = 1..jump←max;
(*CONSTANTS*)
(***********)
bpointer = PACKED RECORD
sbits,pbits: bitrange;
ibit,dummybit: ibrange;
ireg: acrange;
reladdr: addrrange
END;
cstclass = (int,reel,pset,strd,strg,bptr);
csp = ↑ constnt;
constnt = RECORD
selfcsp: csp; nocode: boolean;
CASE cclass: cstclass OF
int : (intval: integer;
intval1:integer (*TO ACCESS SECOND WORD OF PVAL*) );
reel: (rval: real);
pset: (pval: SET OF setrange);
strd,
strg: (slgth: 0..strglgth;
sval: PACKED ARRAY [1..strglgth] OF char);
bptr: (byte: bpointer)
END;
valu = RECORD
CASE integer OF
1: (ival: integer);
2: (valp: csp);
3: (byte: bpointer)
END;
(*DATA STRUCTURES*)
(*****************)
structform = (scalar,subrange,pointer,power,arrays,records,files,tagfwithid,tagfwithoutid,variant);
declkind = (standard,declared);
stp = ↑structure;
ctp = ↑identifier;
structure = PACKED RECORD
selfstp: stp; size: addrrange;
nocode: boolean; bitsize: bitrange;
CASE form: structform OF
scalar: (CASE scalkind: declkind OF
declared: (db0: bits6; fconst: ctp;
vectoraddr, vectorchain: addrrange;
dimension: integer; nextscalar: stp;
request: boolean; tlev: levrange));
subrange: (db1: bits7; rangetype: stp; vmin, vmax: valu);
pointer: (db2: bits7; eltype: stp);
power: (db3: bits7; elset: stp);
arrays: (arraypf: boolean; db4: bits6; arraybpaddr: addrrange;
aeltype, inxtype: stp);
records: (recordpf: boolean; db5: bits6;
fstfld: ctp; recvar: stp);
files: (db6: bits6; filepf: boolean; filtype: stp;
file←form: fileformrange; file←mode: filemoderange);
tagfwithid,
tagfwithoutid: (db7: bits7; fstvar: stp;
CASE boolean OF
true : (tagfieldp: ctp);
false: (tagfieldtype: stp));
variant: (db9: bits7; nxtvar, subvar: stp; firstfield: ctp; varval: valu)
END;
btp = ↑bytepoint;
bytepoint = PACKED RECORD
last: btp;
arraysp: stp;
bitsize: bitrange
END;
gtp = ↑globptr;
globptr = RECORD
nextglobptr: gtp ;
firstglob,
lastglob : addrrange ;
fcix : coderange
END ;
ftp = ↑filblck;
filblck = PACKED RECORD
nextftp : ftp ;
fileident : ctp
END ;
ptp = ↑programparameter;
programparameter = PACKED RECORD
nextptp: ptp;
fileidptr: ctp;
fileid: alfa;
inputfile: boolean
END;
(*NAMES*)
(*******)
scalarform = (integerform,charform,realform,boolform,declaredform);
idclass = (types,konst,vars,field,proc,func,labels);
setofids = SET OF idclass;
idkind = (actual,formal);
packkind = (notpack,packk,hwordr,hwordl);
identifier = PACKED RECORD
name: alfa;
llink, rlink: ctp;
idtype: stp; next: ctp;
selfctp: ctp; nocode: boolean;
CASE klass: idclass OF
konst: (values: valu);
vars: (vkind: idkind;
vlev: levrange;
channel: acrange;
vdummy1: bits5;
vdummy2: bits18;
vaddr: addrrange);
field: (CASE packf: packkind OF
notpack,
hwordl,
hwordr: (hdummy: bits12; fldaddr: addrrange);
packk: (pdummy: bits12; fldbyte: bpointer));
proc,
func: (CASE pfdeckind: declkind OF
standard: (key: keyrange);
declared: (pflev: levrange;
parlistsize,pfaddr: addrrange;
highest←register: acrange;
CASE pfkind: idkind OF
actual: (forwdecl: boolean;
externdecl: boolean;
activated: boolean;
pfchain:ctp;
language: symbol;
testfwdptr: ctp;
externalname: alfa;
linkchain: PACKED ARRAY[levrange] OF addrrange);
formal: (fparam:ctp)));
labels:(scope: levrange;
jump←index: 0..jump←max;
exit←jump: boolean;
goto←chain: addrrange;
label←address: addrrange)
END;
disprange = 0..displimit;
where = (blck (* ID IS VARIABLE ID*)
,crec (* ID IS FIELD ID OF RECORD WITH CONSTANT ADDRESS*)
,vrec (* ID IS FIELD ID OF RECORD WITH VARIABLE ADDRESS*)
);
(*RELOCATION*)
(************)
coderefs = (noref,constref,externref,forwardref,gotoref,pointref,noinstr,saveref,debugref);
relbyte = (no,right,left,both);
relword = PACKED ARRAY[0..17] OF relbyte;
supports = ( stackoverflow, errorinassignment, indexerror, overflow, inputerror,
errorinset, nocoreavailable,
allocate, free,
exitprogram, runprogram, readpgmparameter,
resetfile, rewritefile, opentty, fortranreset, fortranexit, closefile,
getcharacter, getfile, getline, putfile, putline, putpage, putbuffer,
initializedebug, enterdebug, loaddebug,
convertintegertoreal,
asciitime, asciidate,
readreal, readinteger, readcharacter, readstring, readpackedstring,
writecharacter, writedefcharacter,
writestring, writedefstring,
writepackedstring, writedefpackedstring,
writeboolean, writedefboolean,
writereal, writedef1real, writedef2real,
writeinteger, writedefinteger,
writehexadecimal, writedefhexadecimal,
writeoctal, writedefoctal,
readirange, readcrange, readrrange,
readscalar,
readiset, readcset, readdset,
wrtscalar,
wrtiset, wrtcset, wrtdset,
startclock, showruntime, badpointer, (* 12. 21.*)
readpseudostring, (* 25.*)
writepseudostring,writedefpseudostring, (* 25.*)
dumpcounts); (* 28.*)
(*EXPRESSIONS*)
(*************)
attrkind = (cst,varbl,expr);
attr = RECORD
typtr: stp;
CASE kind: attrkind OF
cst: (cval: valu);
varbl: (packfg: packkind;
indexr: acrange;
indbit: ibrange;
vlevel: levrange;
bpaddr,dplmt: addrrange;
vrelbyte: relbyte;
subkind: stp;
vclass: idclass;
vbyte: bpointer);
expr: (reg:acrange)
END;
testp = ↑ testpointer;
testpointer = PACKED RECORD
elt1,elt2: stp;
lasttestp: testp
END;
(*OTHER TYPES:*)
(**************)
lineandpage = RECORD (* 28. KEEPS INFO FOR STATEMENT COUNTS*)
line, page: addrrange;
END;
cntarray = ARRAY[1..100] OF lineandpage;
%24
cntp = ↑cntblock;
cntblock = PACKED RECORD
next : cntp;
lineinfo: cntarray;
END;
\
write←form = (write←entry,write←name,write←hiseg,write←globals,write←code,write←internals,write←library,
write←debug,write←fileblocks,write←symbols,write←start,write←end,write←counters); (* 28.*)
namekind = (stdconst,stdfile,stdproc,stdfunc,declproc,declfunc);
btpkind = (unused,requested,calculated,used);
kindofmsg = (intmsg,alfamsg);
etp = ↑ errorwithtext;
errorwithtext = PACKED RECORD
number: integer;
next: etp;
CASE msgkind: kindofmsg OF
intmsg: (intval: integer);
alfamsg: (string: alfa);
END;
ksp = ↑ konstrec;
konstrec = PACKED RECORD
addr, kaddr: addrrange;
constptr: csp;
nextkonst: ksp;
double←chain: boolean
END;
pdp10instr = PACKED RECORD
instr : instrange ;
ac : acrange;
indbit : ibrange;
inxreg : acrange;
address : addrrange
END ;
change←form=(intcst,pdp10code,realcst,strcst,sixbitcst,halfwd,pdp10bp,radix) ;
charword = PACKED ARRAY[1..5] OF char;
halfs = PACKED RECORD
lefthalf: addrrange;
righthalf: addrrange
END;
codepointer = ↑codearray;
codearray = RECORD
CASE change←form OF
pdp10code: (instruction: ARRAY[coderange] OF pdp10instr);
intcst: (word: ARRAY[coderange] OF integer);
halfwd: (halfword: ARRAY[coderange] OF halfs)
END;
relpointer = ↑relarray;
relarray = PACKED ARRAY[coderange] OF relbyte;
refpointer = ↑refarray;
refarray = PACKED ARRAY[coderange] OF coderefs;
bufferpointer = ↑commandbuffer;
commandbuffer = PACKED ARRAY[0..buffer←size] OF ascii;
pageelem = PACKED RECORD
word1: pdp10instr;
lhalf: addrrange; rhalf: addrrange
END;
debentry = RECORD
lastpageelem: pageelem;
globalidtree: addrrange;
standardidtree: addrrange;
intpoint: stp;
realpoint: stp;
boolpoint: stp;
charpoint: stp
END;
nlk = ↑newlinks;
newlinks = PACKED RECORD
reftype : stp;
refadr : addrrange;
next : nlk;
END;
%24 (* 19. NEEDED FOR PUTADR.*)
supportaddrarray = PACKED ARRAY [supports] OF addrrange;
extaddrvector = PACKED ARRAY [1..extpfmax] OF addrrange;
extaddrarray = PACKED ARRAY [declproc..declfunc] OF extaddrvector;
(* 19.*) \
(* 25. FOR COMPILER-GENERATED PARAMETERS FOR THE SSTRING PROCEDURES.*)
sstrptr = ↑sstringparlength;
sstringparlength = PACKED RECORD
count: 0..2;
value: ARRAY[1..2] OF 1..xtrastrglgth;
next: sstrptr;
END;
(*------------------------------------------------------------------------------*)
VAR
%24 (* 18.*)
userprog: RECORD (* EXECUTABLE CODE OF THE USER PROGRAM.*)
CASE integer OF
1: (execode: ARRAY [0..maxcode] OF integer);
2: (exehalfs: ARRAY [0..maxcode] OF halfs);
END;
(* USERPROG SHOULD ALWAYS BE THE FIRST DECLARED VARIABLE.*)
(* 18.*) \
(*VALUES RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL:*)
(*****************************************************)
sy: symbol; (*LAST SYMBOL*)
op: operator; (*CLASSIFICATION OF LAST SYMBOL*)
val: valu; (*VALUE OF LAST CONSTANT*)
lgth: integer; (*LENGTH OF LAST STRING CONSTANT*)
id: alfa; (*LAST IDENTIFIER (POSSIBLY TRUNCATED)
OR LAST INTEGER CONST (FOR LABEL PROCESSING)*)
ch: char; (*LAST CHARACTER*)
(*COUNTERS:*)
(***********)
i, j: integer;
entries: integer;
support←index: supports;
%13 language←index: symbol; (* 17.*) \
chcntmax: 0..stdchcntmax;
chcnt: 0..stdchcntmax; (*CHARACTER COUNTER*)
tchcnt: integer;
symcnt: integer; (* 30. TO GIVE EXTRA ADVICE ON ERROR ON THE FIRST TOKEN OF A LINE*)
codeend, (*FIRST LOCATION NOT USED FOR INSTRUCTIONS*)
%24 userareastart, (* 20. FIRST LOCATION USED FOR FILE DESCRIPTOR BLOCKS *)
%24 datastart, (* 20. FIRST LOCATION USED FOR USER PROGRAM DATA *)
%24 filelc, (* 20. DATA LOCATION FOR FILE DESCRIPTOR BLOCKS.*) \
lcmain, lc,ic: addrrange; (*DATA LOCATION AND INSTRUCTION COUNTER*)
%13 program←count: integer; (* 14.*) \
%24 execodecount: integer; (* 18.*) \
(*SWITCHES:*)
(***********)
dp, (*DECLARATION PART*)
reset←possible, (*TO IGNORE SWITCHES WHICH MUST NOT BE RESET*)
search←error, (*TO ALLOW FORWARD REFERENCES IN POINTER TYPE
DECLARATION BY SUPPRESSING ERROR MESSAGE*)
%13 external, (*IF TRUE, ALL LEVEL-1 PROC/FUNC MAY BE
DECLARED AS "EXTERN" BY OTHER PROGRAMS*) (* 14.*) \
ttyread, (*TO INHIBIT TTYOPEN ('*'-PROMPTING) IF NO TTY-INPUT REQUESTED*)
outputwrite, (* 13. TO INHIBIT REWRITE OF OUTPUT IF NOT USED*)
inputpar, (* 13. TO INHIBIT RESET OF INPUT IF IT IS A PROGRAM PARAMETER.*)
outputpar, (* 13. SAME FOR OUTPUT.*)
debug, (*ENABLE DEBUGGING*)
debug←switch, (*TO GENERATE DEBUG INFORMATION*)
%13 list←code, (*LIST MACRO CODE*) (* 14.*) \
lptfile, (*TO INHIBIT GENERATION OF LIST-FILE*)
logfile, (*to send to a log file a copy of the tty messages*)
initglobals, (*INITIALIZE GLOBAL VARIABLES*)
loadnoptr, (*IF TRUE, NO POINTERVARIABLE SHALL BE LOADED*)
%13 fortran←enviroment, (* 14.*) \
%13 loadit, (* 14.*) \
%13 load←and←go, (* 14.*) \
cross←reference, (*IF TRUE, PCROSS SHOULD BE CALLED AT THE END*)
counting, (*TRUE IF STATEMENT COUNTS (PROFILE) ARE REQUIRED*)
resettty, (*if false, external procedures are not expected to input from tty*)
openoutput, (*if false, external calls do not expect to write to output*)
runtime←check, (*IF TRUE, PERFORM RUNTIME-TESTS*)
genprocfile, (*true if /PRC was set, to give procedure line info*)
incondcomp, (*TRUE WHEN INSIDE A CONDITIONALLY-COMPILED PART*) (* 8.*)
hassoslines, (* true if the source file has sos lines*)
parsingparameters, (* 25. TRUE WHEN CALL←NON←STANDARD IS PARSING THE PARAMETERS.*)
recall, (* 25. FOR COMPTYPES TO AVOID COUNTING TWICE WHEN RECURSING.*)
first←symbol: boolean; (* TRUE BEFORE THE FIRST SYMBOL IN THE PROGRAM IS PARSED*)
(*POINTERS:*)
(***********)
sexternpfptr,
localpfptr, externpfptr: ctp; (*PTRS TO LOCAL/EXTERNAL PROC/FUNC-CHAIN*)
parmptr: ptp; (*PTR TO PROGRAMPARM.-CHAIN*)
stdfileptr: ARRAY[1..4] OF ctp; (*PTRS TO STD-FILES*)
sstringptr, strgrngptr, (* 25. PREDEFINED STRING AND 1..135 TYPES *)
strgrng0ptr, (* 25. PREDEFINED TYPE 0..135 *)
packc135ptr, (* 25. FOR THE TYPE OF STRTEXT IN STRING.*)
packc1ptr, (* 25. TO CONVERT CHARACTERS TO STRING CONSTANTS.*)
packc0ptr, (* 25. FOR THE CONSTANT NULLSTR.*)
alfaptr,packc9ptr,
packc3ptr,packc5ptr,asciiptr,
packc6ptr,packc8ptr,
intptr,realptr,charptr,
boolptr,nilptr,textptr: stp; (*POINTERS TO ENTRIES OF STANDARD IDS*)
sdeclscalptr,
declscalptr: stp; (*PTR TO CHAIN OF DECLARED SCALARS*)
utypptr,ucstptr,uvarptr,
ufldptr,uprcptr,ufctptr, (*POINTERS TO ENTRIES FOR UNDECLARED IDS*)
forward←pointer←type: ctp; (*HEAD OF CHAIN OF FORW DECL TYPE IDS*)
errmptr, errmptr1: etp; (*TO CHAIN ERRORS WITH TEXT*)
last←label: ctp; (*TOP OF LABEL CHAIN*)
slastbtp,
lastbtp: btp; (*HEAD OF BYTEPOINTERTABLE*)
sfileptr,
fileptr: ftp;
firstkonst: ksp;
anyfileptr: stp; (*TO ALLOW FILES OF "ANY" TYPE AS
VAR PARAMETERS IN STAND. PROC/FUNC*)
fglobptr,cglobptr : gtp ; (*POINTER TO FIRST AND CURRENT GLOBAL INITIALISATION RECORD*)
globtestp : testp ; (*POINTER TO LAST PAIR OF POINTERTYPES*)
globnewlink : nlk ; (*POINTER TO NEW-LINKS*)
(*BOOKKEEPING OF DECLARATION LEVELS:*)
(************************************)
currname: alfa; (* 27.NAME OF THE CURRENT PROCEDURE/FUNCTION*)
level: levrange; (*CURRENT STATIC LEVEL*)
disx, (*LEVEL OF LAST ID SEARCHED BY SEARCHID*)
top: disprange; (*TOP OF DISPLAY*)
display: ARRAY[disprange] OF
PACKED RECORD
fname: ctp;
CASE occur: where OF
crec: (clev: levrange;
cindr: acrange;
cindb: ibrange;
crelbyte: relbyte;
cdspl,
clc : addrrange)
END;
(*ERROR MESSAGES:*)
(*****************)
error←flag: boolean; (*TRUE IF SYNTACTIC ERRORS DETECTED IN ONE PROGRAM*)
no←code←gen: boolean; (*IF TRUE, WRITE←MACHINE←CODE WILL NOT EXECUTE*)
(*SET BY ANY ERRORS OR BY /NOLOAD IN PASSGO*)
error←in←heading: boolean;
error←in←first: boolean; (* 30. TRUE IF THE EXTRA ADVICE MESSAGE IS NEEDED*)
errinx: 0..maxerr ; (*NR OF ERRORS IN CURRENT SOURCE LINE*)
errorcount: integer; (*TOTAL NR OF ERRORS DETECTED IN PROGRAM*)
error←exit: boolean; (*TO ENABLE EXIT DURING COMPILATION*)
overrun: boolean;
errlist:
ARRAY [1..maxerr] OF
PACKED RECORD
arw: 1..maxerr;
pos: 1..stdchcntmax;
nmr: 1..600;
tic: char
END;
errmess15 : ARRAY [1..24] OF PACKED ARRAY [1..15] OF char;
errmess20 : ARRAY [1..15] OF PACKED ARRAY [1..20] OF char;
errmess25 : ARRAY [1..18] OF PACKED ARRAY [1..25] OF char;
errmess30 : ARRAY [1..21] OF PACKED ARRAY [1..30] OF char;
errmess35 : ARRAY [1..17] OF PACKED ARRAY [1..35] OF char;
errmess40 : ARRAY [1..13] OF PACKED ARRAY [1..40] OF char;
errmess45 : ARRAY [1..20] OF PACKED ARRAY [1..45] OF char;
errmess50 : ARRAY [1..10] OF PACKED ARRAY [1..50] OF char;
errmess55 : ARRAY [1.. 8] OF PACKED ARRAY [1..55] OF char;
errorinline,
followerror : boolean;
errline,
buffer: ARRAY [1..stdchcntmax] OF char;
firstpage, (* 6. PAGE AT WHICH THE PROGRAM STARTS. *)
pagecnt,
linecnt: integer;
linenr: PACKED ARRAY [1..5] OF char;
(*EXPRESSION COMPILATION:*)
(*************************)
gattr: attr; (*DESCRIBES THE EXPR CURRENTLY COMPILED*)
aos: (b0,b1,b2,b3,aosinstr,sosinstr); (*TESTS CONDITION FOR AOS/SOS-INSTRUCTION*)
leftside: attr; (*LEFT SIDE OF ASSIGNMENT*)
(*COMPILATION OF PACKED STRUCTURES:*)
(***********************************)
arraybps: ARRAY[1:18] OF
RECORD
abyte: bpointer; bytemax: bitrange;
address: addrrange;
state: btpkind
END;
(*DEBUG-SYSTEM:*)
(***************)
laststop: addrrange; (*LAST BREAKPOINT*)
lastline, (*LINENUMBER FOR BREAKPOINTS*)
linediff, (*DIFFERENCE BETWEEN ↑ AND LINECNT*)
lastpage:integer; (*LAST PAGE THAT CONTAINS A STOP*)
pageheadadr, (*OVERGIVE TO DEBUG.PAS*)
lastpager: addrrange; (*POINTS AT LAST PAGERECORD*)
pager: pageelem; (*ACTUAL PAGERECORD*)
debentry←size: integer; (*DEBENTRY LENGTH *)
debugentry: debentry;
idrecsize: ARRAY[idclass] OF integer;
strecsize: ARRAY[structform] OF integer;
(*STRUCTURED CONSTANTS:*)
(***********************)
lettersordigits,letters,digits,lettersdigitsorleftarrow,hexadigits: SET OF char;
constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys,
languagesys,statbegsys,typedels: setofsys;
rw: ARRAY [1..rswmax] OF alfa;
frw: ARRAY [1..11(*ALFALENGTH+1*)] OF 1..rswmaxp1;
rsy: ARRAY [1..rswmax] OF symbol;
ssy: ARRAY [' '..'←'] OF symbol;
rop: ARRAY [1..rswmax] OF operator;
sop: ARRAY [' '..'←'] OF operator;
na: ARRAY[namekind] OF ARRAY[1..stdmax] OF alfa; (* PASCAL NAMES OF THE KNOWN RUNTIMES.*)
namax: ARRAY[namekind] OF integer; (* NUMBER OF NAMES IN NA FOR EACH FIRST SUBSCRIPT.*)
extna: ARRAY[declproc..declfunc] OF ARRAY[1..extpfmax] OF alfa; (* SIX-LETTER NAMES OF THOSE RUNTIMES.*)
extlanguage: ARRAY[declproc..declfunc] OF ARRAY[1..extpfmax] OF symbol; (* FOR CALLING CONVENTIONS.*)
%24 extaddr: extaddrarray; (* 19. ACTUAL ADDRESSES OF THE PREDECLARED RUNTIMES.*) \
%13 (* 14.*)
mnemonics : ARRAY[1..45] OF PACKED ARRAY[1..60] OF char ;
showibit : ARRAY[ibrange] OF char;
showrelo : ARRAY[boolean] OF char;
showref : ARRAY[coderefs] OF char;
(* 14.*) \
write←support, read←support: ARRAY[scalarform,scalar..power] OF supports;
(*LABEL PROCESSING:*)
(*******************)
jumper: 0..jump←max;
jump←table: PACKED ARRAY[jump←range] OF addrrange;
jump←address: addrrange;
%24 (* 24. FOR INITPROCEDURES IN PASSGO.*)
initproccount: integer;
initpraddress: PACKED ARRAY [0..99] OF addrrange;
(* 24.*) \
(*OTHER VARIABLES:*)
(********************)
relocation←block: PACKED RECORD
CASE integer OF
1: (component: ARRAY[1..20] OF integer);
2: (item: addrrange; count: addrrange;
relocator: relword;
code: ARRAY[0..17] OF integer)
END;
runtime←support: PACKED RECORD
name: ARRAY[supports] OF alfa;
link: PACKED ARRAY[supports] OF addrrange
END;
code←array: codepointer;
code←reference: refpointer;
%13 command←buffer: bufferpointer; (* 18.*) \
code←relocation: relpointer;
change : PACKED RECORD
CASE change←form OF
intcst :(wkonst: integer);
pdp10code:(winstr: pdp10instr);
realcst :(wreal: real);
strcst :(wstring: charword);
sixbitcst:(wsixbit: PACKED ARRAY[1..6] OF 0..77B);
halfwd :(wlefthalf: addrrange ; wrighthalf : addrrange);
pdp10bp :(wbyte: bpointer);
radix :(flag: flagrange; symbol: radixrange)
END;
regc, (*TOP OF REGISTERSTACK*)
regcmax: acrange; (*MAXIMUM OF REGISTERS FOR EXPRESSION STACK*)
cix, (*CODE-ARRAY INDEX*)
stacksize1, stacksize2, (*TO INSERT LCMAX IN PROCEDURE/FUNCTION ENTRY CODE*)
pfstart: integer; (*START OF NORMAL ENTRYCODE OF EACH FUNC. OR PROC.*)
lcmax: addrrange; lcp: ctp;
headline: integer; (* 27. LINE NUMBER OF THE HEADER OF THIS PROCEDURE*)
procfile, (* 27. FILE WITH PROCEDURE NAMES AND LINE NUMBERS*)
tempcore, source, list : text;
object: FILE OF integer; (*26. A FAKE REL FILE FOR DEBUGGING OF PASSGO*)
withix: integer; (*TOP OF WITH-REG STACK*)
highest←code, (*HIGH SEG. BREAK*)
main←start, (*START OF BODY OF MAIN*)
idtree, (*POINTER TO THE IDENTIFIER-TREE*)
name←address, (*ADDR OF PROGRAM-NAME(ALFA-STRING)*)
start←address: addrrange; (*STARTADDRESS*)
lparmptr, backwparmptr: ptp;
day, timeofday, programname: alfa;
entry: ARRAY[0..entrymax] OF alfa;
%13 object←file, (* 14.*) \
procname←file, (* 27. FILE NAME FOR DUMP OF PROCEDURE NAMES/LINES*)
source←file, list←file: PACKED ARRAY [1..9] OF char;
(* 23. RUNTIME REPORTED BY THE LIBRARY PROCEDURES.*)
core: ARRAY[1..2] OF integer;
goodversion, (*VERSION NUMBER TO BE CONDITIONALLY COMPILED*) (* 8.*)
maxruncore,
start←channel, code←size, runcore, parregcmax: integer;
%13 entry←done: boolean; (* 19.*) \
(* 25. STRING LENGTH FOR CALL OF STRING-MANAGING PROCEDURES.*)
sstringstart: boolean;
sstringlength: sstrptr;
pctp : ctp;
list←protection , list←ufd : integer ;
list←device : PACKED ARRAY [1..6] OF char ;
suptindex: supports; (* 26.*)
(* 4. ALLOW FOR FLEXIBLE NAME OF PCROSS FILE; KEEP TABLE OF PCROSS SWITCHES.*)
%13 pcross←file, (* 14.*) \
pcross←tmpfile: PACKED ARRAY [1..9] OF char;
%13 pcross←device, (* 14.*) \
source←device: PACKED ARRAY[1..6] OF char;
%24 pcross←file,
pcross←device: alfa; (* 14.*) \
pcross←ppn, pcross←core: integer;
pcross←option←name: PACKED ARRAY [1..maxpcrossoption] OF alfa;
(* 1. ALLOW FOR FLEXIBLE NAME OF LINKER-LOADER.*)
linker←file,
link←tmpfile: PACKED ARRAY[1..9] OF char;
link←device: PACKED ARRAY[1..6] OF char;
%13 (* 17.*)
link←ppn: integer;
library←index: integer;
library←order: PACKED ARRAY[1..4] OF symbol;
library: ARRAY[pascalsy..fortransy] OF RECORD
chained, called: boolean;
name: alfa;
projnr: addrrange;
prognr: addrrange;
device: alfa
END;
(* 17.*) \
(* 28. STATEMENT COUNTS*)
(***********************)
%13 lastlcmain: addrrange; \
%13 line←count: cntarray; \
counter: 1..101;
startofcounts,endofcounts: addrrange;
%24 firstcntp,lastcntp: cntp; \
kntname: alfa;
entercount: boolean;
(*------------------------------------------------------------------------------*)
(* INITPROCEDURES. *)
%13 (* 14. THE OBJECT CODE LISTING IS NOT IN PASSGO *)
INITPROCEDURE (* MNEMONICS *) ;
BEGIN
mnemonics[ 1] := '***001***002***003***004***005***006***007***010***011***012' ;
mnemonics[ 2] := '***013***014***015***016***017***020***021***022***023***024' ;
mnemonics[ 3] := '***025***026***027***030***031***032***033***034***035***036' ;
mnemonics[ 4] := '***037CALL INIT ***042***043***044***045***046CALLI OPEN ' ;
mnemonics[ 5] := 'TTCALL***052***053***054RENAMEIN OUT SETSTSSTATO STATUS' ;
mnemonics[ 6] := 'STATZ INBUF OUTBUFINPUT OUTPUTCLOSE RELEASMTAPE UGETF USETI ' ;
mnemonics[ 7] := 'USETO LOOKUPENTER UJEN ***101***102***103***104***105***106' ;
mnemonics[ 8] := '***107***110***111***112***113***114***115***116***117***120' ;
mnemonics[ 9] := '***121***122***123***124***125***126***127UFA DFN FSC ' ;
mnemonics[10] := 'IBP ILDB LDB IDPB DPB FAD FADL FADM FADB FADR ' ;
mnemonics[11] := 'FADRI FADRM FADRB FSB FSBL FSBM FSBB FSBR FSBRI FSBRM ' ;
mnemonics[12] := 'FSBRB FMP FMPL FMPM FMPB FMPR FMPRI FMPRM FMPRB FDV ' ;
mnemonics[13] := 'FDVL FDVM FDVB FDVR FDVRI FDVRM FDVRB MOVE MOVEI MOVEM ' ;
mnemonics[14] := 'MOVES MOVS MOVSI MOVSM MOVSS MOVN MOVNI MOVNM MOVNS MOVM ' ;
mnemonics[15] := 'MOVMI MOVMM MOVMS IMUL IMULI IMULM IMULB MUL MULI MULM ' ;
mnemonics[16] := 'MULB IDIV IDIVI IDIVM IDIVB DIV DIVI DIVM DIVB ASH ' ;
mnemonics[17] := 'ROT LSH JFFO ASHC ROTC LSHC ***247EXCH BLT AOBJP ' ;
mnemonics[18] := 'AOBJN JRST JFCL XCT ***257PUSHJ PUSH POP POPJ JSR ' ;
mnemonics[19] := 'JSP JSA JRA ADD ADDI ADDM ADDB SUB SUBI SUBM ' ;
mnemonics[20] := 'SUBB CAI CAIL CAIE CAILE CAIA CAIGE CAIN CAIG CAM ' ;
mnemonics[21] := 'CAML CAME CAMLE CAMA CAMGE CAMN CAMG JUMP JUMPL JUMPE ' ;
mnemonics[22] := 'JUMPLEJUMPA JUMPGEJUMPN JUMPG SKIP SKIPL SKIPE SKIPLESKIPA ' ;
mnemonics[23] := 'SKIPGESKIPN SKIPG AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN ' ;
mnemonics[24] := 'AOJG AOS AOSL AOSE AOSLE AOSA AOSGE AOSN AOSG SOJ ' ;
mnemonics[25] := 'SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG SOS SOSL SOSE ' ;
mnemonics[26] := 'SOSLE SOSA SOSGE SOSN SOSG SETZ SETZI SETZM SETZB AND ' ;
mnemonics[27] := 'ANDI ANDM ANDB ANDCA ANDCAIANDCAMANDCABSETM SETMI SETMM ' ;
mnemonics[28] := 'SETMB ANDCM ANDCMIANDCMMANDCMBSETA SETAI SETAM SETAB XOR ' ;
mnemonics[29] := 'XORI XORM XORB IOR IORI IORM IORB ANDCB ANDCBIANDCBM' ;
mnemonics[30] := 'ANDCBBEQV EQVI EQVM EQVB SETCA SETCAISETCAMSETCABORCA ' ;
mnemonics[31] := 'ORCAI ORCAM ORCAB SETCM SETCMISETCMMSETCMBORCM ORCMI ORCMM ' ;
mnemonics[32] := 'ORCMB ORCB ORCBI ORCBM ORCBB SETO SETOI SETOM SETOB HLL ' ;
mnemonics[33] := 'HLLI HLLM HLLS HRL HRLI HRLM HRLS HLLZ HLLZI HLLZM ' ;
mnemonics[34] := 'HLLZS HRLZ HRLZI HRLZM HRLZS HLLO HLLOI HLLOM HLLOS HRLO ' ;
mnemonics[35] := 'HRLOI HRLOM HRLOS HLLE HLLEI HLLEM HLLES HRLE HRLEI HRLEM ' ;
mnemonics[36] := 'HRLES HRR HRRI HRRM HRRS HLR HLRI HLRM HLRS HRRZ ' ;
mnemonics[37] := 'HRRZI HRRZM HRRZS HLRZ HLRZI HLRZM HLRZS HRRO HRROI HRROM ' ;
mnemonics[38] := 'HRROS HLRO HLROI HLROM HLROS HRRE HRREI HRREM HRRES HLRE ' ;
mnemonics[39] := 'HLREI HLREM HLRES TRN TLN TRNE TLNE TRNA TLNA TRNN ' ;
mnemonics[40] := 'TLNN TDN TSN TDNE TSNE TDNA TSNA TDNN TSNN TRZ ' ;
mnemonics[41] := 'TLZ TRZE TLZE TRZA TLZA TRZN TLZN TDZ TSZ TDZE ' ;
mnemonics[42] := 'TSZE TDZA TSZA TDZN TSZN TRC TLC TRCE TLZE TRCA ' ;
mnemonics[43] := 'TLCA TRCN TLCN TDC TSC TDCE TSCE TDCA TSCA TDCN ' ;
mnemonics[44] := 'TSCN TRO TLO TROE TLOE TROA TLOA TRON TLON TDO ' ;
mnemonics[45] := 'TSO TDOE TSOE TDOA TSOA TDON TSON ***700 ' ;
showibit[0] := ' '; showibit[1] := '@';
showrelo[false] := ' '; showrelo[true] := '''';
showref[noref] := ' '; showref[constref] := 'C';
showref[externref] := 'E'; showref[noinstr] := ' ';
showref[forwardref] := 'F'; showref[gotoref] := 'G';
showref[pointref] := 'P'; showref[saveref] := 'S';
showref[debugref] := 'D';
END (* MNEMONICS *) ;
(* 14.*) \
%13 (* 14. PASCAL VERSION.*)
INITPROCEDURE (*SEARCH LIBRARIES*) ;
BEGIN
(* INSERT (???) DEVICE, PROJNR, PROGNR AND CORE FOR PASLIB AND PCROSS *)
library[pascalsy].chained := false;
library[fortransy].chained := false;
library[pascalsy].called := false;
library[fortransy].called := false;
library[pascalsy].name := 'PASLIB ';
library[fortransy].name := 'FORLIB ';
library[pascalsy].device := 'SYS '; (* 0. *)
library[fortransy].device := 'SYS ';
library[pascalsy].projnr := 0;
library[fortransy].projnr := 0;
library[pascalsy].prognr := 0;
library[fortransy].prognr := 0;
(* 4. FLEXIBLE NAME FOR CROSS←REFERENCER*)
pcross←file := 'PCROSS ';
pcross←tmpfile := 'PCR TMP';
pcross←device := 'SYS '; (* 0.*)
pcross←ppn := 0;
pcross←core := 100;
(* 1. FLEXIBLE NAME FOR THE LINKER.*)
linker←file := 'link ';
link←tmpfile := 'lnk TMP';
link←device := 'SYS ';
link←ppn := 0;
END (*SEARCH LIBRARIES*) ;
(* 14.*) \
%24 (* PASSGO VERSION.*)
INITPROCEDURE (*SEARCH LIBRARIES*);
BEGIN
pcross←file := 'PCROSS ';
pcross←tmpfile := 'PCR TMP';
pcross←device := 'SYS ';
pcross←ppn := 0;
pcross←core := 100;
END (*SEARCH LIBRARIES*);
(* 14.*) \
INITPROCEDURE (*STANDARD NAMES*) ;
BEGIN
na[stdfile, 1] := 'INPUT '; na[stdfile, 2] := 'OUTPUT '; na[stdfile, 3] := 'TTY ';
na[stdfile, 4] := 'TTYOUTPUT ';
na[stdproc, 1] := 'GET '; na[stdproc, 2] := 'GETLN '; na[stdproc, 3] := 'PUT ';
na[stdproc, 4] := 'PUTLN '; na[stdproc, 5] := 'RESET '; na[stdproc, 6] := 'REWRITE ';
na[stdproc, 7] := 'READ '; na[stdproc, 8] := 'READLN '; na[stdproc, 9] := 'BREAK ';
na[stdproc,10] := 'WRITE '; na[stdproc,11] := 'WRITELN '; na[stdproc,12] := 'PACK ';
na[stdproc,13] := 'UNPACK '; na[stdproc,14] := 'NEW '; na[stdproc,15] := '$$$1 ';
na[stdproc,16] := '$$$2 '; na[stdproc,17] := 'GETLINENR '; na[stdproc,18] := '$$$3 ';
na[stdproc,19] := 'PAGE '; na[stdproc,20] := 'PROTECTION'; na[stdproc,21] := 'CALL ';
na[stdproc,22] := 'DATE '; na[stdproc,23] := 'TIME '; na[stdproc,24] := 'DISPOSE ';
na[stdproc,25] := 'HALT '; na[stdproc,26] := 'GETSEG '; na[stdproc,27] := 'PUTSEG ';
na[stdproc,28] := 'MESSAGE '; na[stdproc,29] := 'LINELIMIT ';
na[stdfunc, 1] := 'REALTIME '; na[stdfunc, 2] := 'ABS '; na[stdfunc, 3] := 'SQR ';
na[stdfunc, 4] := '$$$4 '; na[stdfunc, 5] := 'ODD '; na[stdfunc, 6] := 'ORD ';
na[stdfunc, 7] := 'CHR '; na[stdfunc, 8] := 'PRED '; na[stdfunc, 9] := 'SUCC ';
na[stdfunc,10] := 'EOF '; na[stdfunc,11] := 'EOLN '; na[stdfunc,12] := 'CLOCK ';
na[stdfunc,13] := 'CARD '; na[stdfunc,14] := '$$$5 '; na[stdfunc,15] := 'LOWERBOUND';
na[stdfunc,16] := 'UPPERBOUND'; na[stdfunc,17] := 'EOS '; na[stdfunc,18] := '$$$6 ';
na[stdfunc,19] := 'MIN '; na[stdfunc,20] := 'MAX '; na[stdfunc,21] := 'FIRST ';
na[stdfunc,22] := 'LAST ';
na[declfunc, 1] := 'COS '; na[declfunc, 2] := 'EXP '; na[declfunc, 3] := 'SQRT ';
na[declfunc, 4] := 'LN '; na[declfunc, 5] := 'ARCTAN '; na[declfunc, 6] := 'LOG ';
na[declfunc, 7] := 'SIND '; na[declfunc, 8] := 'COSD '; na[declfunc, 9] := 'SINH ';
na[declfunc,10] := 'COSH '; na[declfunc,11] := 'TANH '; na[declfunc,12] := 'ARCSIN ';
na[declfunc,13] := 'ARCCOS '; na[declfunc,14] := 'RANDOM '; na[declfunc,15] := 'SIN ';
na[declfunc,16] := 'ROUND '; na[declfunc,17] := 'EXPO '; na[declfunc,18] := 'OPTION ';
na[declfunc,19] := '$$$7 '; na[declfunc,20] := 'TRUNC '; na[declfunc,21] := 'LENGTH '; (* 25.*)
na[declfunc,22] := 'GETCHAR '; na[declfunc,23] := 'POS '; na[declfunc,24] := 'STRLT '; (* 25.*)
na[declfunc,25] := 'STRLE '; na[declfunc,26] := 'STREQ '; na[declfunc,27] := 'STRGE '; (* 25.*)
na[declfunc,28] := 'STRGT '; na[declfunc,29] := 'STRNE '; (* 25.*)
na[stdconst, 1] := 'FALSE '; na[stdconst, 2] := 'TRUE '; na[stdconst, 3] := 'NUL ';
na[stdconst, 4] := 'SOH '; na[stdconst, 5] := 'STX '; na[stdconst, 6] := 'ETX ';
na[stdconst, 7] := 'EOT '; na[stdconst, 8] := 'ENQ '; na[stdconst, 9] := 'ACK ';
na[stdconst,10] := 'BEL '; na[stdconst,11] := 'BS '; na[stdconst,12] := 'HT ';
na[stdconst,13] := 'LF '; na[stdconst,14] := 'VT '; na[stdconst,15] := 'FF ';
na[stdconst,16] := 'CR '; na[stdconst,17] := 'SO '; na[stdconst,18] := 'SI ';
na[stdconst,19] := 'DLE '; na[stdconst,20] := 'DC1 '; na[stdconst,21] := 'DC2 ';
na[stdconst,22] := 'DC3 '; na[stdconst,23] := 'DC4 '; na[stdconst,24] := 'NAK ';
na[stdconst,25] := 'SYN '; na[stdconst,26] := 'ETB '; na[stdconst,27] := 'CAN ';
na[stdconst,28] := 'EM '; na[stdconst,29] := 'SUB '; na[stdconst,30] := 'ESC ';
na[stdconst,31] := 'FS '; na[stdconst,32] := 'GS '; na[stdconst,33] := 'RS ';
na[stdconst,34] := 'US '; na[stdconst,35] := 'SP '; na[stdconst,36] := 'DEL ';
na[declproc, 1] := 'GETFILENAM'; na[declproc, 2] := 'GETOPTION '; na[declproc, 3] := 'GETSTATUS ';
(* 7. NEW RUNTIMES FROM THE CCL SCANNER.*)
na[declproc, 4] := 'ASKFILENAM'; na[declproc, 5] := 'STARTFILE '; na[declproc, 6] := 'GETPARAMET';
na[declproc, 7] := 'GETNEXTCAL'; na[declproc, 8] := 'FILNAM '; na[declproc, 9] := 'REENTER ';
na[declproc,10] := 'SETTIME '; na[declproc,11] := 'TIMEREPORT'; na[declproc,12] := 'RUNTIME ';
na[declproc,13] := 'ELAPSEDTIM'; na[declproc,14] := 'PUTCHAR '; na[declproc,15] := 'ASSIGN '; (* 25.*)
na[declproc,16] := 'SUBSTR '; na[declproc,17] := 'CONCAT '; na[declproc,18] := 'SETRAN '; (*25.*) (*29.*)
namax[stdfile] := 4; namax[stdproc] := 29; namax[stdfunc] := 22; (* 25.*)
namax[declfunc] := 29; namax[declproc] := 18; namax[stdconst] := 36; (* 25.*)
END (*STANDARD NAMES*) ;
INITPROCEDURE (*EXTERNAL PROCEDURE/FUNCTION NAMES*);
BEGIN
extna[declfunc, 1] := 'COS '; extlanguage[declfunc, 1] := fortransy;
extna[declfunc, 2] := 'EXP '; extlanguage[declfunc, 2] := fortransy;
extna[declfunc, 3] := 'PSQRT '; extlanguage[declfunc, 3] := pascalsy; (* 29.*)
extna[declfunc, 4] := 'ALOG '; extlanguage[declfunc, 4] := fortransy;
extna[declfunc, 5] := 'ATAN '; extlanguage[declfunc, 5] := fortransy;
extna[declfunc, 6] := 'ALOG10 '; extlanguage[declfunc, 6] := fortransy;
extna[declfunc, 7] := 'SIND '; extlanguage[declfunc, 7] := fortransy;
extna[declfunc, 8] := 'COSD '; extlanguage[declfunc, 8] := fortransy;
extna[declfunc, 9] := 'SINH '; extlanguage[declfunc, 9] := fortransy;
extna[declfunc,10] := 'COSH '; extlanguage[declfunc,10] := fortransy;
extna[declfunc,11] := 'TANH '; extlanguage[declfunc,11] := fortransy;
extna[declfunc,12] := 'ASIN '; extlanguage[declfunc,12] := fortransy;
extna[declfunc,13] := 'ACOS '; extlanguage[declfunc,13] := fortransy;
extna[declfunc,14] := 'RAN '; extlanguage[declfunc,14] := fortransy;
extna[declfunc,15] := 'SIN '; extlanguage[declfunc,15] := fortransy;
extna[declfunc,16] := 'ROUND '; extlanguage[declfunc,16] := pascalsy;
extna[declfunc,17] := 'EXPO '; extlanguage[declfunc,17] := pascalsy;
extna[declfunc,18] := 'OPTION '; extlanguage[declfunc,18] := pascalsy;
extna[declfunc,19] := 'UNDEFI '; extlanguage[declfunc,19] := pascalsy;
extna[declfunc,20] := 'TRUNC '; extlanguage[declfunc,20] := pascalsy;
extna[declfunc,21] := 'LENGTH '; extlanguage[declfunc,21] := pascalsy; (* 25.*)
extna[declfunc,22] := 'GETCHA '; extlanguage[declfunc,22] := pascalsy; (* 25.*)
extna[declfunc,23] := 'POS '; extlanguage[declfunc,23] := pascalsy; (* 25.*)
extna[declfunc,24] := 'STRLT '; extlanguage[declfunc,24] := pascalsy; (* 25.*)
extna[declfunc,25] := 'STRLE '; extlanguage[declfunc,25] := pascalsy; (* 25.*)
extna[declfunc,26] := 'STREQ '; extlanguage[declfunc,26] := pascalsy; (* 25.*)
extna[declfunc,27] := 'STRGE '; extlanguage[declfunc,27] := pascalsy; (* 25.*)
extna[declfunc,28] := 'STRGT '; extlanguage[declfunc,28] := pascalsy; (* 28.*)
extna[declfunc,29] := 'STRNE '; extlanguage[declfunc,29] := pascalsy; (* 25.*)
extna[declproc, 1] := 'GETFIL '; extlanguage[declproc, 1] := pascalsy;
extna[declproc, 2] := 'GETOPT '; extlanguage[declproc, 2] := pascalsy;
extna[declproc, 3] := 'GETSTA '; extlanguage[declproc, 3] := pascalsy;
(* 7. NEW RUNTIMES FROM THE CCL SCANNER.*)
extna[declproc, 4] := 'ASKFIL '; extlanguage[declproc, 4] := pascalsy;
extna[declproc, 5] := 'STARTF '; extlanguage[declproc, 5] := pascalsy;
extna[declproc, 6] := 'GETPAR '; extlanguage[declproc, 6] := pascalsy;
extna[declproc, 7] := 'GETNEX '; extlanguage[declproc, 7] := pascalsy;
extna[declproc, 8] := 'FILNAM '; extlanguage[declproc, 8] := pascalsy;
extna[declproc, 9] := 'REENTE '; extlanguage[declproc, 9] := pascalsy;
extna[declproc,10] := 'SETTIM '; extlanguage[declproc,10] := pascalsy;
extna[declproc,11] := 'TIMERE '; extlanguage[declproc,11] := pascalsy;
extna[declproc,12] := 'RUNTIM '; extlanguage[declproc,12] := pascalsy;
extna[declproc,13] := 'ELAPSE '; extlanguage[declproc,13] := pascalsy;
extna[declproc,14] := 'PUTCHA '; extlanguage[declproc,14] := pascalsy; (* 25.*)
extna[declproc,15] := 'ASSIGN '; extlanguage[declproc,15] := pascalsy; (* 25.*)
extna[declproc,16] := 'SUBSTR '; extlanguage[declproc,16] := pascalsy; (* 25.*)
extna[declproc,17] := 'CONCAT '; extlanguage[declproc,17] := pascalsy; (* 25.*)
extna[declproc,18] := 'SETRAN '; extlanguage[declproc,18] := fortransy;
END (*EXTERNAL PROCEDURE/FUNCTION NAMES*);
INITPROCEDURE (*RUNTIME-, DEBUG-SUPPORT NAMES*) ;
BEGIN
(* 13. REORDERED ACCORDING TO THE DECLARATION OF TYPE SUPPORTS.*)
runtime←support.name[stackoverflow] := 'CORERR ';
runtime←support.name[errorinassignment] := 'SRERR ';
runtime←support.name[indexerror] := 'INXERR ';
runtime←support.name[overflow] := 'OVERF. ';
runtime←support.name[inputerror] := 'IPTERR ';
runtime←support.name[errorinset] := 'SETERR ';
runtime←support.name[nocoreavailable] := 'NOCORE ';
runtime←support.name[allocate] := 'NEW ';
runtime←support.name[free] := 'FREE ';
runtime←support.name[exitprogram] := 'END ';
runtime←support.name[runprogram] := 'RUNPGM ';
runtime←support.name[readpgmparameter] := 'GETPAR ';
runtime←support.name[resetfile] := 'RESETF ';
runtime←support.name[rewritefile] := 'REWRIT ';
runtime←support.name[opentty] := 'TTYOPN ';
runtime←support.name[fortranreset] := 'RESET. ';
runtime←support.name[fortranexit] := 'EXIT. ';
runtime←support.name[closefile] := 'CLSFIL ';
runtime←support.name[getcharacter] := 'GETCH ';
runtime←support.name[getfile] := 'GET ';
runtime←support.name[getline] := 'GETLN ';
runtime←support.name[putfile] := 'PUT ';
runtime←support.name[putline] := 'PUTLN ';
runtime←support.name[putpage] := 'PUTPG ';
runtime←support.name[putbuffer] := 'PUTBUF ';
runtime←support.name[initializedebug] := 'INDEB. ';
runtime←support.name[enterdebug] := 'EXDEB. ';
runtime←support.name[loaddebug] := 'DEBUG ';
runtime←support.name[convertintegertoreal] := 'INTREA ';
runtime←support.name[asciitime] := 'TIME. ';
runtime←support.name[asciidate] := 'DATE. ';
runtime←support.name[readreal] := 'READR ';
runtime←support.name[readinteger] := 'READI ';
runtime←support.name[readcharacter] := 'READC ';
runtime←support.name[readstring] := 'READS ';
runtime←support.name[readpackedstring] := 'READPS ';
runtime←support.name[writecharacter] := 'WRITEC ';
runtime←support.name[writedefcharacter] := 'WRITC1 ';
runtime←support.name[writestring] := 'WRTUST ';
runtime←support.name[writedefstring] := 'WRTUS1 ';
runtime←support.name[writepackedstring] := 'WRTPST ';
runtime←support.name[writedefpackedstring] := 'WRTPS1 ';
runtime←support.name[writeboolean] := 'WRTBOL ';
runtime←support.name[writedefboolean] := 'WRTBO1 ';
runtime←support.name[writereal] := 'WRTREA ';
runtime←support.name[writedef1real] := 'WRTRE1 ';
runtime←support.name[writedef2real] := 'WRTRE2 ';
runtime←support.name[writeinteger] := 'WRTINT ';
runtime←support.name[writedefinteger] := 'WRTIN1 ';
runtime←support.name[writehexadecimal] := 'WRTHEX ';
runtime←support.name[writedefhexadecimal] := 'WRTHX1 ';
runtime←support.name[writeoctal] := 'WRTOCT ';
runtime←support.name[writedefoctal] := 'WRTOC1 ';
runtime←support.name[readirange] := 'READIR ';
runtime←support.name[readcrange] := 'READCR ';
runtime←support.name[readrrange] := 'READRR ';
runtime←support.name[readscalar] := 'READSC ';
runtime←support.name[readiset] := 'READIS ';
runtime←support.name[readcset] := 'READCS ';
runtime←support.name[readdset] := 'READDS ';
runtime←support.name[wrtscalar] := 'WRTSCA ';
runtime←support.name[wrtiset] := 'WRTISE ';
runtime←support.name[wrtcset] := 'WRTCSE ';
runtime←support.name[wrtdset] := 'WRTDSE ';
runtime←support.name[startclock] := 'SETTIM ';
runtime←support.name[showruntime] := 'TIMERE ';
runtime←support.name[badpointer] := 'PTRERR ';
runtime←support.name[readpseudostring] := 'READST '; (* 25.*)
runtime←support.name[writepseudostring] := 'WRTSTR '; (* 25.*)
runtime←support.name[writedefpseudostring] := 'WRTST1 '; (* 25.*)
runtime←support.name[dumpcounts ] := 'DPCNTS ';
read←support[integerform,subrange] := readirange;
read←support[integerform,power] := readiset;
read←support[integerform,scalar] := readinteger;
read←support[realform,subrange] := readrrange;
read←support[realform,scalar] := readreal;
read←support[charform,subrange] := readcrange;
read←support[charform,power] := readcset;
read←support[charform,scalar] := readcharacter;
read←support[declaredform,subrange] := readscalar;
read←support[declaredform,power] := readdset;
read←support[declaredform,scalar] := readscalar;
write←support[integerform,power] := wrtiset;
write←support[charform,power] := wrtcset;
write←support[declaredform,power] := wrtdset;
write←support[declaredform,subrange] := wrtscalar;
write←support[declaredform,scalar] := wrtscalar;
END (*RUNTIME-, DEBUG-SUPPORT NAMES*) ;
INITPROCEDURE (*INITSCALARS*) ;
BEGIN
programname := ' ';
forward←pointer←type := NIL; lastbtp := NIL; fglobptr := NIL ; fileptr := NIL ;
localpfptr := NIL; externpfptr := NIL; globtestp := NIL; last←label := NIL;
errmptr := NIL; parmptr := NIL; declscalptr := NIL; backwparmptr := NIL;
sdeclscalptr := NIL; sexternpfptr := NIL; sfileptr := NIL;
slastbtp := NIL; globnewlink := NIL;
%13 list←code := false; \ loadnoptr := true; initglobals := false ; runtime←check := true;
followerror := false; errorinline := false; reset←possible := true; first←symbol := true;
dp := true; search←error := true; error←flag := false ; %13 external := false; \
no←code←gen := false; hassoslines := true; logfile := false;
%13 entry←done := false; \ debug := false; debug←switch := false; lptfile := false;
error←exit := false; ttyread := false; %13 load←and←go := false; loadit := false; \
cross←reference := false; %13 fortran←enviroment := false; \ overrun := false;
incondcomp := false; (* 8. INITIALLY OUT OF CONDITIONAL COMPILATION.*)
outputwrite := false; inputpar := false; outputpar := false; (* 13.*)
entercount := false; counting := false; (* 28.*)
%13 ic := high←start; (*START OF HIGHSEGMENT*) (* 14.*) \
%13 lc := low←start; (*START OF LOWSEGMENT AVAILABLE TO PROGRAM*) (* 14.*) \
chcnt := 0; linecnt := 1; pagecnt := 1; lastline := -1;
tchcnt := 0;
aos := b0; %13 library←index := 0; (* 17.*) \ errinx := 0;
debugentry.standardidtree := 0; debugentry.globalidtree := 0; start←channel := 0;
parregcmax := stdparregcmax; chcntmax := stdchcntmax;
code←size := cixmax; %12 runcore := 170B; \ jumper := 0; jump←address := 0;
%34 runcore := 0; \ maxruncore := 170B;
errorcount := 0; entries := 0; %13 program←count := 0; (* 14.*) \
lastpage := 0; goodversion := -1; (* 8. VERSION TO BE TAKEN.*)
%24 execodecount := maxfilecode; (* 18.*) \
%24 initproccount := -1; (* 24.*) \
END (*INITSCALARS*) ;
INITPROCEDURE (*INITSETS*) ;
BEGIN
digits := ['0'..'9'];
letters := ['A'..'Z'];
hexadigits := ['0'..'9','A'..'F'];
lettersordigits := [ '0'..'9','A'..'Z'];
lettersdigitsorleftarrow := ['0'..'9','A'..'Z','←'];
languagesys := [fortransy,pascalsy];
constbegsys := [addop,intconst,realconst,stringconst,ident];
simptypebegsys := [addop,intconst,realconst,stringconst,ident,lparent] ;
typebegsys := [addop,intconst,realconst,stringconst,ident,lparent,arrow,
packedsy,arraysy,recordsy,setsy,filesy,segmentsy] ; (* 13.*)
typedels := [arraysy,recordsy,setsy,filesy];
blockbegsys := [labelsy,constsy,typesy,varsy,initprocsy,proceduresy,functionsy,beginsy];
selectsys := [arrow,period,lbrack];
facbegsys := [intconst,realconst,stringconst,ident,lparent,lbrack,notsy];
statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,loopsy,forsy,withsy,casesy]
END (*INITSETS*) ;
INITPROCEDURE (*RESERVED WORDS*) ;
BEGIN
rw[ 1] := 'IF '; rw[ 2] := 'DO '; rw[ 3] := 'OF ';
rw[ 4] := 'TO '; rw[ 5] := 'IN '; rw[ 6] := 'OR ';
rw[ 7] := 'END '; rw[ 8] := 'FOR '; rw[ 9] := 'VAR ';
rw[10] := 'DIV '; rw[11] := 'MOD '; rw[12] := 'SET ';
rw[13] := 'AND '; rw[14] := 'NOT '; rw[15] := 'THEN ';
rw[16] := 'ELSE '; rw[17] := 'WITH '; rw[18] := 'GOTO ';
rw[19] := 'LOOP '; rw[20] := 'CASE '; rw[21] := 'TYPE ';
rw[22] := 'FILE '; rw[23] := 'EXIT '; rw[24] := 'BEGIN ';
rw[25] := 'UNTIL '; rw[26] := 'WHILE '; rw[27] := 'ARRAY ';
rw[28] := 'CONST '; rw[29] := 'LABEL '; rw[30] := 'EXTERN ';
rw[31] := 'RECORD '; rw[32] := 'DOWNTO '; rw[33] := 'PACKED ';
rw[34] := 'OTHERS '; rw[35] := 'REPEAT '; rw[36] := 'FORTRAN ';
rw[37] := 'FORWARD '; rw[38] := 'PROGRAM '; rw[39] := 'FUNCTION ';
rw[40] := 'PROCEDURE '; rw[41] := 'SEGMENTED '; rw[42] := 'INITPROCED';
frw[1] := 1; frw[2] := 1; frw[3] := 7; frw[4] := 15; frw[5] := 24;
frw[6] := 30; frw[7] := 36; frw[8] := 39; frw[9] := 40; frw[10] := 42;
frw[11] := 43
END (*RESERVED WORDS*) ;
INITPROCEDURE (*SYMBOLS*) ;
BEGIN
rsy[1]:=ifsy; rsy[2]:=dosy; rsy[3]:=ofsy;
rsy[4]:=tosy; rsy[8]:=forsy; rsy[12]:=setsy;
rsy[5]:=relop; rsy[6]:=addop; rsy[7]:=endsy;
rsy[9]:=varsy; rsy[10]:=mulop; rsy[11]:=mulop;
rsy[13]:=mulop; rsy[14]:=notsy; rsy[15]:=thensy;
rsy[16]:=elsesy; rsy[17]:=withsy; rsy[18]:=gotosy;
rsy[19]:=loopsy; rsy[20]:=casesy; rsy[21]:=typesy;
rsy[22]:=filesy; rsy[23]:=exitsy; rsy[24]:=beginsy;
rsy[25]:=untilsy; rsy[26]:=whilesy; rsy[27]:=arraysy;
rsy[28]:=constsy; rsy[29]:=labelsy; rsy[30]:=externsy;
rsy[31]:=recordsy; rsy[32]:=downtosy; rsy[33]:=packedsy;
rsy[34]:=otherssy; rsy[35]:=repeatsy; rsy[36]:=fortransy;
rsy[37]:=forwardsy; rsy[38]:=programsy; rsy[39]:=functionsy;
rsy[40]:=proceduresy; rsy[41]:=segmentsy; rsy[42]:=initprocsy;
ssy['A'] := othersy; ssy['B'] := othersy; ssy['C'] := othersy;
ssy['D'] := othersy; ssy['E'] := othersy; ssy['F'] := othersy;
ssy['G'] := othersy; ssy['H'] := othersy; ssy['I'] := othersy;
ssy['J'] := othersy; ssy['K'] := othersy; ssy['L'] := othersy;
ssy['M'] := othersy; ssy['N'] := othersy; ssy['O'] := othersy;
ssy['P'] := othersy; ssy['Q'] := othersy; ssy['R'] := othersy;
ssy['S'] := othersy; ssy['T'] := othersy; ssy['U'] := othersy;
ssy['V'] := othersy; ssy['W'] := othersy; ssy['X'] := othersy;
ssy['Y'] := othersy; ssy['Z'] := othersy; ssy['0'] := othersy;
ssy['1'] := othersy; ssy['2'] := othersy; ssy['3'] := othersy;
ssy['4'] := othersy; ssy['5'] := othersy; ssy['6'] := othersy;
ssy['7'] := othersy; ssy['8'] := othersy; ssy['9'] := othersy;
ssy['+'] := addop; ssy['-'] := addop; ssy['*'] := mulop;
ssy['/'] := mulop; ssy['('] := lparent; ssy[')'] := rparent;
ssy['$'] := othersy; ssy['='] := relop; ssy[' '] := othersy;
ssy[','] := comma; ssy['.'] := period; ssy[''''] := othersy;
ssy['['] := lbrack; ssy[']'] := rbrack; ssy[':'] := colon;
ssy['#'] := othersy; ssy['%'] := othersy; ssy['!'] := othersy;
ssy['&'] := othersy; ssy['↑'] := arrow; ssy['\'] := othersy;
ssy['<'] := relop; ssy['>'] := relop; ssy['@'] := othersy;
ssy['"'] := othersy; ssy['?'] := othersy; ssy[';'] := semicolon;
ssy['←'] := othersy;
END (*SYMBOLS*) ;
INITPROCEDURE (*OPERATORS*) ;
BEGIN
rop[ 1] := noop; rop[ 2] := noop; rop[ 3] := noop; rop[ 4] := noop;
rop[ 5] := inop; rop[ 6] := orop; rop[ 7] := noop; rop[ 8] := noop;
rop[ 9] := noop; rop[10] := idiv; rop[11] := imod; rop[12] := noop;
rop[13] :=andop; rop[14] := noop; rop[15] := noop; rop[16] := noop;
rop[17] := noop; rop[18] := noop; rop[19] := noop; rop[20] := noop;
rop[21] := noop; rop[22] := noop; rop[23] := noop; rop[24] := noop;
rop[25] := noop; rop[26] := noop; rop[27] := noop; rop[28] := noop;
rop[29] := noop; rop[30] := noop; rop[31] := noop; rop[32] := noop;
rop[33] := noop; rop[34] := noop; rop[35] := noop; rop[36] := noop;
rop[37] := noop; rop[38] := noop; rop[39] := noop; rop[40] := noop;
rop[41] := noop; rop[42] := noop;
sop['+'] := plus; sop['-'] := minus; sop['*'] := mul; sop['/'] := rdiv;
sop['='] := eqop; sop['#'] := noop; sop['!'] := noop; sop['&'] := noop;
sop['<'] := ltop; sop['>'] := gtop; sop['@'] := noop; sop['"'] := noop;
sop[' '] := noop; sop['$'] := noop; sop['%'] := noop; sop['('] := noop;
sop[')'] := noop; sop[','] := noop; sop['.'] := noop; sop['0'] := noop;
sop['1'] := noop; sop['2'] := noop; sop['3'] := noop; sop['4'] := noop;
sop['5'] := noop; sop['6'] := noop; sop['7'] := noop; sop['8'] := noop;
sop['9'] := noop; sop[':'] := noop; sop[';'] := noop; sop['?'] := noop;
sop['A'] := noop; sop['B'] := noop; sop['C'] := noop; sop['D'] := noop;
sop['E'] := noop; sop['F'] := noop; sop['G'] := noop; sop['H'] := noop;
sop['I'] := noop; sop['J'] := noop; sop['K'] := noop; sop['L'] := noop;
sop['M'] := noop; sop['N'] := noop; sop['O'] := noop; sop['P'] := noop;
sop['Q'] := noop; sop['R'] := noop; sop['S'] := noop; sop['T'] := noop;
sop['U'] := noop; sop['V'] := noop; sop['W'] := noop; sop['X'] := noop;
sop['Y'] := noop; sop['Z'] := noop; sop['['] := noop; sop['\'] := noop;
sop[']'] := noop; sop['↑'] := noop; sop['←'] := noop; sop[''''] := noop
END (*OPERATORS*) ;
INITPROCEDURE (*RECORD SIZES*);
BEGIN
debentry←size := 8;
idrecsize[types] := 5;
idrecsize[konst] := 6;
idrecsize[vars] := 6;
idrecsize[field] := 6;
idrecsize[proc] := 5;
idrecsize[func] := 5;
idrecsize[labels] := 5;
strecsize[scalar] := 2;
strecsize[subrange] := 4;
strecsize[pointer] := 2;
strecsize[power] := 2;
strecsize[arrays] := 3;
strecsize[records] := 3;
strecsize[files] := 2;
strecsize[tagfwithid] := 3;
strecsize[tagfwithoutid] := 2;
strecsize[variant] := 4
END (*RECORD SIZES*);
INITPROCEDURE (*ERROR MESSAGES*) ;
BEGIN
errmess15[ 1] := '":" EXPECTED ';
errmess15[ 2] := '")" EXPECTED ';
errmess15[ 3] := '"(" EXPECTED ';
errmess15[ 4] := '"[" EXPECTED ';
errmess15[ 5] := '"]" EXPECTED ';
errmess15[ 6] := '";" EXPECTED ';
errmess15[ 7] := '"=" EXPECTED ';
errmess15[ 8] := '"," EXPECTED ';
errmess15[ 9] := '":=" EXPECTED ';
errmess15[10] := '"OF" EXPECTED ';
errmess15[11] := '"DO" EXPECTED ';
errmess15[12] := '"IF" EXPECTED ';
errmess15[13] := '"END" EXPECTED ';
errmess15[14] := '"THEN" EXPECTED';
errmess15[15] := '"EXIT" EXPECTED';
errmess15[16] := 'ILLEGAL SYMBOL ';
errmess15[17] := 'NO SIGN ALLOWED';
errmess15[18] := 'NUMBER EXPECTED';
errmess15[19] := 'NOT IMPLEMENTED';
errmess15[20] := 'ERROR IN TYPE ';
errmess15[21] := 'COMPILER ERROR ';
errmess15[22] := 'DEVICE EXPECTED';
errmess15[23] := 'ERROR IN FACTOR';
errmess15[24] := 'TOO MANY DIGITS';
errmess20[ 1] := '"BEGIN" EXPECTED ';
errmess20[ 2] := '"UNTIL" EXPECTED ';
errmess20[ 3] := 'ERROR IN OPTIONS ';
errmess20[ 4] := 'CONSTANT TOO LARGE ';
errmess20[ 5] := 'DIGIT MUST FOLLOW ';
errmess20[ 6] := 'EXPONENT TOO LARGE ';
errmess20[ 7] := 'CONSTANT EXPECTED ';
errmess20[ 8] := 'SIMPLE TYPE EXPECTED';
errmess20[ 9] := 'IDENTIFIER EXPECTED ';
errmess20[10] := 'REALTYPE NOT ALLOWED';
errmess20[11] := 'MULTIDEFINED LABEL ';
errmess20[12] := 'FILENAME EXPECTED ';
errmess20[13] := 'SET TYPE EXPECTED ';
errmess20[14] := 'UNDEFINED LABEL ';
errmess20[15] := 'UNDECLARED LABEL ';
errmess25[ 1] := '"TO"/"DOWNTO" EXPECTED ';
errmess25[ 2] := '8 OR 9 IN OCTAL NUMBER ';
errmess25[ 3] := 'IDENTIFIER NOT DECLARED ';
errmess25[ 4] := 'FILE NOT ALLOWED HERE ';
errmess25[ 5] := 'INTEGER CONSTANT EXPECTED';
errmess25[ 6] := 'ERROR IN PARAMETERLIST ';
errmess25[ 7] := 'ALREADY FORWARD DECLARED ';
errmess25[ 8] := 'THIS FORMAT FOR REAL ONLY';
errmess25[ 9] := 'VARIANTTYPE MUST BE ARRAY';
errmess25[10] := 'TYPE CONFLICT OF OPERANDS';
errmess25[11] := 'MULTIDEFINED CASE LABEL ';
errmess25[12] := 'FOR INTEGER ONLY "O"/"H" ';
errmess25[13] := 'ARRAY INDEX OUT OF BOUNDS';
errmess25[14] := 'MISSING FILE DECLARATION ';
errmess25[15] := 'LABEL CONSTANT TOO GREAT ';
errmess25[16] := 'LABEL ALREADY DECLARED ';
errmess25[17] := 'END OF PROGRAM NOT FOUND ';
errmess25[18] := 'MORE THAN 72 SET ELEMENTS';
errmess30[ 1] := 'STRING CONSTANT IS TOO LONG ';
errmess30[ 2] := 'IDENTIFIER ALREADY DECLARED ';
errmess30[ 3] := 'SUBRANGE BOUNDS MUST BE SCALAR';
errmess30[ 4] := 'INCOMPATIBLE SUBRANGE TYPES ';
errmess30[ 5] := 'INCOMPATIBLE WITH TAGFIELDTYPE';
errmess30[ 6] := 'INDEX TYPE MAY NOT BE INTEGER ';
errmess30[ 7] := 'TYPE OF VARIABLE IS NOT ARRAY ';
errmess30[ 8] := 'TYPE OF VARIABLE IS NOT RECORD';
errmess30[ 9] := 'NO SUCH FIELD IN THIS RECORD ';
errmess30[10] := 'EXPRESSION TOO COMPLICATED ';
errmess30[11] := 'ILLEGAL TYPE OF OPERAND(S) ';
errmess30[12] := 'TESTS ON EQUALITY ALLOWED ONLY';
errmess30[13] := 'STRICT INCLUSION NOT ALLOWED ';
errmess30[14] := 'FILE COMPARISON NOT ALLOWED ';
errmess30[15] := 'ILLEGAL TYPE OF EXPRESSION ';
errmess30[16] := 'VALUE OF CASE LABEL TOO LARGE ';
errmess30[17] := 'TOO MANY NESTED WITHSTATEMENTS';
errmess30[18] := 'INVALID OR NO PROGRAM HEADING ';
errmess30[19] := 'TOO MANY LABEL DECLARATIONS ';
errmess30[20] := 'INCOMPATIBLE FORMALPARAMETER ';
errmess30[21] := 'STRING PACKAGE IS DISABLED '; (* 25.*)
errmess35[ 1] := 'STRING CONSTANT CONTAINS "<CR><LF>"';
errmess35[ 2] := 'LABEL NOT DECLARED ON THIS LEVEL ';
errmess35[ 3] := 'CALL NOT ALLOWED IN EXTERN PROGRAMS';
errmess35[ 4] := 'MORE THAN 12 FILES DECLARED BY USER';
errmess35[ 5] := 'FILE AS VALUE PARAMETER NOT ALLOWED';
errmess35[ 6] := 'TOO MUCH CODE: USE OPTION CODESIZE ';
errmess35[ 7] := 'NO PACKED STRUCTURE ALLOWED HERE ';
errmess35[ 8] := 'VARIANT MUST BELONG TO TAGFIELDTYPE';
errmess35[ 9] := 'TYPE OF OPERAND(S) MUST BE BOOLEAN ';
errmess35[10] := 'SET ELEMENT TYPES NOT COMPATIBLE ';
errmess35[11] := 'ASSIGNMENT TO FILES NOT ALLOWED ';
errmess35[12] := 'TOO MANY LABELS IN THIS PROCEDURE ';
errmess35[13] := 'INITPROCEDURE NOT ALLOWED HERE ';
errmess35[14] := 'CONTROL VARIABLE MAY NOT BE FORMAL ';
errmess35[15] := 'ILLEGAL TYPE OF FOR-CONTROLVARIABLE';
errmess35[16] := 'ONLY PACKED FILE OF CHAR ALLOWED ';
errmess35[17] := 'CONSTANT NOT IN BOUNDS OF SUBRANGE ';
errmess40[ 1] := 'IDENTIFIER IS NOT OF APPROPRIATE CLASS ';
errmess40[ 2] := 'TAGFIELD TYPE MUST BE SCALAR OR SUBRANGE';
errmess40[ 3] := 'INDEX TYPE MUST BE SCALAR OR SUBRANGE ';
errmess40[ 4] := 'TOO MANY NESTED SCOPES OF IDENTIFIERS ';
errmess40[ 5] := 'POINTER FORWARD REFERENCE UNSATISFIED ';
errmess40[ 6] := ' ';
errmess40[ 7] := 'TYPE OF VARIABLE MUST BE FILE OR POINTER';
errmess40[ 8] := 'MISSING CORRESPONDING VARIANTDECLARATION';
errmess40[ 9] := 'MORE THAN 6 VARIANTS IN CALL OF "NEW" ';
errmess40[10] := 'MORE THAN FOUR ERRORS IN THIS SOURCELINE';
errmess40[11] := 'NO INITIALISATION ON RECORDS OR FILES ';
errmess40[12] := 'PROGRAM TOO BIG FOR PASSGO. USE PASCAL ';
errmess40[13] := 'MORE THAN 100 INITPROCEDURES. USE PASCAL';
errmess45[ 1] := 'LOW BOUND MAY NOT BE GREATER THAN HIGH BOUND ';
errmess45[ 2] := 'IDENTIFIER OR "CASE" EXPECTED IN FIELDLIST ';
errmess45[ 3] := 'TOO MANY NESTED PROCEDURES AND/OR FUNCTIONS ';
errmess45[ 4] := 'FILE DECLARATION IN PROCEDURES NOT ALLOWED ';
errmess45[ 5] := 'MISSING RESULT TYPE IN FUNCTION DECLARATION ';
errmess45[ 6] := 'ASSIGNMENT TO FORMAL FUNCTION IS NOT ALLOWED ';
errmess45[ 7] := 'INDEX TYPE IS NOT COMPATIBLE WITH DECLARATION';
errmess45[ 8] := 'ERROR IN TYPE OF STANDARD PROCEDURE PARAMETER';
errmess45[ 9] := 'ERROR IN TYPE OF STANDARD FUNCTION PARAMETER ';
errmess45[10] := 'REAL AND STRING TAGFIELDS NOT IMPLEMENTED ';
errmess45[11] := 'SET ELEMENT TYPE MUST BE SCALAR OR SUBRANGE ';
errmess45[12] := 'ONLY ASSIGNMENTS ALLOWED IN INITPROCEDURES ';
errmess45[13] := 'NO CONSTANT OR EXPRESSION FOR VAR ARGUMENT ';
errmess45[14] := 'EXTERN DECLARATION NOT ALLOWED IN PROCEDURES ';
errmess45[15] := 'BODY OF FORWARD DECLARED PROCEDURE MISSING ';
errmess45[16] := 'DOUBLE FILE SPECIFICATION IN PROGRAM HEADING ';
errmess45[17] := 'TOO MUCH CODE FOR DEBUG: TRY MORE "CODESIZE" ';
errmess45[18] := 'NO FORMAL-PROC/FUNC IN FORTRAN-SUBROUTINE ';
errmess45[19] := 'THIS VAR ARGUMENT HAS TO BE OF TYPE STRING ';
errmess45[20] := 'GLOBAL VARIABLES REQUIRE TOO MUCH MEMORYSPACE';
errmess50[ 1] := 'TOO MANY FORWARD REFERENCES OF PROCEDURE ENTRIES ';
errmess50[ 2] := 'ASSIGNMENT TO STANDARD FUNCTION IS NOT ALLOWED ';
errmess50[ 3] := 'PARAMETER TYPE DOES NOT AGREE WITH DECLARATION ';
errmess50[ 4] := 'INITIALISATION ONLY BY ASSIGNMENT OF CONSTANTS ';
errmess50[ 5] := 'LABEL TYPE INCOMPATIBLE WITH SELECTING EXPRESSION ';
errmess50[ 6] := 'PREV. STATEMENT MISSING ";","END","ELSE"OR"UNTIL" ';
errmess50[ 7] := 'NOT ALLOWED IN INITPROCEDURES (PACKED STRUCTURE?) ';
errmess50[ 8] := 'GOTO INTO MAIN PROGRAM NOT ALLOWED IF "EXTERN" ';
errmess50[ 9] := 'ASSIGNMENT TO FUNCTION NOT ALLOWED ON THIS LEVEL ';
errmess50[10] := 'NO STD- OR FORTRAN-PROC/FUNC AS ACTUAL-PROC/FUNC ';
errmess55[ 1] := 'FUNCTION RESULT TYPE MUST BE SCALAR,SUBRANGE OR POINTER';
errmess55[ 2] := 'REPETITION OF RESULT TYPE NOT ALLOWED IF FORW. DECL. ';
errmess55[ 3] := 'REPETITION OF PARAMETER LIST NOT ALLOWED IF FORW. DECL.';
errmess55[ 4] := 'NUMBER OF PARAMETERS DOES NOT AGREE WITH DECLARATION ';
errmess55[ 5] := 'RESULT TYPE OF PARAMETER-FUNC DOES NOT AGREE WITH DECL.';
errmess55[ 6] := 'SELECTED EXPRESSION MUST HAVE TYPE OF CONTROL VARIABLE ';
errmess55[ 7] := 'TOO MANY FILES OR TOO BIG FILE ELEMENTS. USE PASCAL. ';
errmess55[ 8] := 'ALREADY DECLARED. PREVIOUS DECLARATION WAS NOT FORWARD ';
END (*ERROR MESSAGES*) ;
INITPROCEDURE (*PCROSS OPTION NAMES*) ;
(* 4. TO BE ABLE TO PASS THEM TO PCROSS *)
BEGIN
pcross←option←name [1] := 'NEW ';
pcross←option←name [2] := 'NONEW ';
pcross←option←name [3] := 'CROSS ';
pcross←option←name [4] := 'NOCROSS ';
pcross←option←name [5] := 'WIDTH ';
pcross←option←name [6] := 'INDENT ';
pcross←option←name [7] := 'INCREMENT ';
pcross←option←name [8] := 'DOTS ';
pcross←option←name [9] := 'NODOTS ';
pcross←option←name [10] := 'BEGIN ';
pcross←option←name [11] := 'FORCE ';
pcross←option←name [12] := 'NOFORCE ';
pcross←option←name [13] := 'CLEAN ';
pcross←option←name [14] := 'NOCLEAN ';
pcross←option←name [15] := 'RES ';
pcross←option←name [16] := 'NONRES ';
pcross←option←name [17] := 'COMM ';
pcross←option←name [18] := 'STR ';
pcross←option←name [19] := 'CASE ';
pcross←option←name [20] := 'version ';
END (*PCROSS OPTION NAMES*) ;
(*----------------------------------------------------------------------------*)
(* init←compile, putadr, location, initpassgo, error *)
PROCEDURE init←compile;
BEGIN (* INIT←COMPILE *)
%13 program←count := program←count + 1; (* 14.*) \
programname := ' ';
forward←pointer←type := NIL; (* 13. LASTBTP REPEATED BELOW.*)
fglobptr := NIL; fileptr := sfileptr;
localpfptr := NIL; declscalptr := sdeclscalptr;
globtestp := NIL; last←label := NIL;
errmptr := NIL; parmptr := NIL;
backwparmptr := NIL; externpfptr := sexternpfptr;
lastbtp := slastbtp; sstringlength := NIL; (* 25.*)
loadnoptr := true; initglobals := false;
followerror := false; errorinline := false;
dp := true; search←error := true;
error←flag := false; overrun := false;
error←exit := false; ttyread := false;
%13 entry←done := false; \ first←symbol := true;
reset←possible := true; incondcomp := false;
outputwrite := false; inputpar := false; (* 13.*)
outputpar := false; (* 13.*) parsingparameters := false; (* 25.*)
sstringstart := false; (* 25.*) error←in←first := false; (* 30.*)
counting := false; (* 28.*)
genprocfile := false;
%13 ic := high←start; lc := low←start; (* 14.*) \
%13 library←index := 0; (* 17.*) \ errinx := 0;
errorcount := 0; entries := 0;
debugentry.standardidtree := 0; debugentry.globalidtree := 0;
jumper := 0; jump←address := 0;
aos := b0; %24 initproccount := -1; (* 24.*) \
symcnt := 0; (* 30.*)
currname := ' '; (* 27.*)
FOR i := 1 TO 18 DO arraybps[i].state := unused;
arraybps[7].state := requested;
FOR i := 1 TO stdchcntmax DO errline[i] := ' ';
%13 (* 19.*)
FOR support←index := first(support←index) TO last(support←index) DO
runtime←support.link[support←index] := 0;
(* 19.*) \
%13 relocation←block.count := 0; (* 18.*) \
top := 1; level := 1;
WITH display[1] DO
BEGIN
fname := NIL; occur := blck
END;
WHILE externpfptr <> NIL DO
WITH externpfptr↑ DO
BEGIN
linkchain[0] := 0; externpfptr := pfchain
END;
externpfptr := sexternpfptr;
WHILE declscalptr <> NIL DO
WITH declscalptr↑ DO
BEGIN
vectoraddr := 0; vectorchain := 0;
request := false; declscalptr := nextscalar
END;
declscalptr := sdeclscalptr;
WHILE lastbtp <> NIL DO
WITH lastbtp↑ DO
BEGIN
arraysp↑.arraybpaddr := 0; lastbtp := last
END;
lastbtp := slastbtp
END (* INIT←COMPILE *);
%24 (* 15. NEEDED TO INITIALIZE PASSGO.*)
PROCEDURE putadr(VAR a1, a2: extaddrvector; VAR b: supportaddrarray);
EXTERN;
FUNCTION location (VAR c: integer): integer;
EXTERN;
FUNCTION locationofafile (VAR f: text): integer;
EXTERN;
PROCEDURE initpassgo;
VAR
i: integer;
BEGIN (* INITPASSGO *)
putadr (extaddr[declproc], extaddr[declfunc], runtime←support.link);
userareastart := location(userprog.execode[0]);
filelc := low←start + userareastart;
ic := userareastart + maxfilecode;
lc := location(i);
datastart := lc;
END (* INITPASSGO *);
(* 15.*) \
PROCEDURE error(ferrnr: integer);
VAR
lpos,larw : integer;
BEGIN (*ERROR*)
IF NOT followerror THEN
BEGIN
errorcount := errorcount + 1; (* 13. KEEP THE ERRORS COUNTED RIGHT.*)
error←flag := true ;
IF errinx >= maxerr THEN
BEGIN
errlist[maxerr].nmr := 410; errinx := maxerr
END
ELSE
BEGIN
errinx := errinx + 1;
WITH errlist[errinx] DO
BEGIN
nmr := ferrnr; tic := '↑'
END
END;
followerror := true; errorinline := true;
IF symcnt = 1 THEN (* 30.*)
error←in←first := true;
IF (ferrnr <> 214) AND (ferrnr <> 356) AND (ferrnr <> 405) AND
(ferrnr <> 465) AND (ferrnr <> 467) AND (ferrnr <> 264) AND
(ferrnr <> 267) THEN
IF eoln(source) THEN errline [chcnt] := '↑'
ELSE errline [chcnt-1] := '↑'
ELSE errlist[errinx].tic := ' ';
IF errinx > 1 THEN WITH errlist [ errinx-1] DO
BEGIN
lpos := pos; larw := arw
END;
WITH errlist [errinx] DO
BEGIN
pos := chcnt;
IF errinx = 1 THEN arw := 1
ELSE
IF lpos = chcnt THEN arw := larw
ELSE arw := larw + 1
END
END
END (*ERROR*) ;
(*symbol table init: enterid, enterstdtypes, enterstdnames, enterundecl*)
PROCEDURE enterid(fcp: ctp);
(*ENTER ID POINTED TO BY FCP INTO THE NAME-TABLE,
WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
AN UNBALANCED BINARY TREE*)
VAR
new←name: alfa; lcp, lcp1: ctp; lleft: boolean;
BEGIN (*ENTERID*)
lcp := display[top].fname;
IF lcp = NIL THEN display[top].fname := fcp
ELSE
BEGIN
new←name := fcp↑.name;
REPEAT
lcp1 := lcp;
IF lcp↑.name <= new←name THEN
BEGIN
IF lcp↑.name = new←name THEN (*NAME CONFLICT*)
IF new←name[1] IN digits THEN error(266) (*MULTI-DECLARED LABEL*)
ELSE error(302) (*MULTI-DECLARED IDENTIFIER*) ;
lcp := lcp↑.rlink; lleft := false
END
ELSE
BEGIN
lcp := lcp↑.llink; lleft := true
END
UNTIL lcp = NIL;
IF lleft THEN lcp1↑.llink := fcp
ELSE lcp1↑.rlink := fcp
END;
WITH fcp↑ DO
BEGIN
llink := NIL; rlink := NIL; selfctp := NIL
END
END (*ENTERID*) ;
PROCEDURE enterstdtypes;
VAR
llcp, lcp: ctp;
PROCEDURE enterstdstring(VAR stringptr: stp; lowbnd, highbnd: integer);
VAR
lbtp: btp; lsp: stp;
BEGIN (*ENTERSTDSTRING*)
new(lsp,subrange);
WITH lsp↑ DO
BEGIN
rangetype := intptr; vmin.ival := lowbnd; vmax.ival := highbnd;
selfstp := NIL; size := 1; bitsize := bitmax
END;
new(stringptr,arrays);
WITH stringptr↑ DO
BEGIN
arraypf := true; arraybpaddr := 0; selfstp := NIL;
aeltype := asciiptr; inxtype := lsp; size := (highbnd-lowbnd+5) DIV 5;
bitsize := bitmax
END;
new(lbtp);
WITH lbtp↑ DO
BEGIN
last := lastbtp; arraysp := stringptr;
bitsize := 7; lastbtp := lbtp
END;
WITH arraybps[7], abyte DO
BEGIN
sbits := 7; pbits := bitmax; dummybit := 0;
ibit := 0; ireg := reg1; reladdr := 0;
bytemax := 6; state := requested
END
END;
BEGIN (*ENTERSTDTYPES*)
new(intptr,scalar,standard); (*INTEGER*)
WITH intptr↑ DO
BEGIN
size := 1;bitsize := bitmax; selfstp := NIL
END;
new(realptr,scalar,standard); (*REAL*)
WITH realptr↑ DO
BEGIN
size := 1;bitsize := bitmax; selfstp := NIL
END;
new(asciiptr,scalar,standard); (*ASCII*)
WITH asciiptr↑ DO
BEGIN
size := 1;bitsize := 7; selfstp := NIL
END;
new(boolptr,scalar,declared); (*BOOLEAN*)
WITH boolptr↑ DO
BEGIN
size := 1;bitsize := 1; selfstp := NIL
END;
new(nilptr,pointer); (*NIL*)
WITH nilptr↑ DO
BEGIN
eltype := NIL; size := 1; bitsize := 18; selfstp := NIL
END;
new(anyfileptr,files); (*"ANY FILE"*)
WITH anyfileptr↑ DO
BEGIN
filtype := NIL; size := 0; bitsize := 0; selfstp := NIL
END;
new(charptr,subrange); (*CHAR*)
WITH charptr↑ DO
BEGIN
size := 1; bitsize := 7; selfstp := NIL;
rangetype := asciiptr; vmin.ival := ord(' ');
vmax.ival := ord('←')
END;
new(textptr,files); (*TEXT*)
WITH textptr↑ DO
BEGIN
filtype := charptr; size := 1+sizeoffileblock; bitsize := bitmax;
file←mode := ascii←mode; filepf := true; selfstp := NIL;
file←form := text←file;
END;
enterstdstring(alfaptr,1,alfalength);
enterstdstring(packc9ptr,1,9);
enterstdstring(packc8ptr,1,8);
enterstdstring(packc6ptr,1,6);
enterstdstring(packc5ptr,1,5);
enterstdstring(packc3ptr,1,3);
slastbtp := lastbtp;
(* 25. STANDARD TYPES NEEDED FOR THE STRING PACKAGE.*)
IF stringpack THEN
BEGIN
enterstdstring(packc135ptr,1,135);
enterstdstring(packc1ptr,1,1);
enterstdstring(packc0ptr,1,0);
new(strgrngptr, subrange); (* STRGRANGE *)
WITH strgrngptr↑ DO
BEGIN
size := 1; bitsize := bitmax; selfstp := NIL;
rangetype := intptr; vmin.ival := 1; vmax.ival := strglgth;
END;
new(strgrng0ptr, subrange); (* STRGRANGE0 *)
WITH strgrng0ptr↑ DO
BEGIN
size := 1; bitsize := bitmax; selfstp := NIL;
rangetype := intptr; vmin.ival := 0; vmax.ival := strglgth;
END;
new(lcp,field); (* STRING.STRTEXT *)
WITH lcp↑ DO
BEGIN
name := 'STRTEXT '; idtype := packc135ptr;
packf := notpack; fldaddr := 0;
END;
enterid(lcp);
llcp := lcp;
new(lcp, field); (* STRING.LEN *)
WITH lcp↑ DO
BEGIN
name := 'LEN '; idtype := strgrng0ptr; next := NIL;
packf := notpack; fldaddr := packc135ptr↑.size;
END;
llcp↑.next := lcp;
enterid(lcp);
new(sstringptr, records); (* STRING *)
WITH sstringptr↑ DO
BEGIN
selfstp := NIL; size := packc135ptr↑.size + 1; bitsize := bitmax;
recordpf := false; fstfld := llcp; recvar := packc135ptr;
END;
END;
END (*ENTERSTDTYPES*) ;
PROCEDURE enterstdnames;
VAR
cp: ctp;
i,j: integer;
lfileptr: ftp;
lcsp: csp;
%24 llc: addrrange; (* 21.*) \
PROCEDURE enterstdprocfunc(findex: integer; fidclass: idclass; fidtype: stp; fnext: ctp);
VAR
i: integer; lcp: ctp; nameix: namekind;
BEGIN (*ENTERSTDPROCFUNC*)
IF fidclass = func THEN
BEGIN
nameix := declfunc; new(lcp,func,declared,actual)
END
ELSE
BEGIN
nameix := declproc; new(lcp,proc,declared,actual)
END;
WITH lcp↑ DO
BEGIN
idtype := fidtype; next := fnext; forwdecl := false; highest←register := stdparregcmax;
pflev := 0; pfaddr := 0; pfchain := externpfptr; externpfptr := lcp; externdecl := true;
FOR i := 0 TO maxlevel DO linkchain[i] := 0;
language := extlanguage[nameix,findex];
externalname := extna[nameix,findex]; name := na[nameix,findex];
%24 pfaddr := extaddr[nameix, findex]; (* 19. PASSGO KNOWS THEIR ADDRESS.*) \
END;
enterid(lcp)
END (*ENTERSTDPROCFUNC*);
PROCEDURE enterstdparameter(fidtype: stp; fidkind: idkind; fnext: ctp; faddr: integer);
BEGIN (*ENTERSTDPARAMETER*)
new(cp,vars);
WITH cp↑ DO
BEGIN
name := ' '; idtype := fidtype;
vkind := fidkind; next := fnext; vlev := 1; vaddr := faddr
END
END (*ENTERSTDPARAMETER*);
PROCEDURE enterstdid(fidclass: idclass; fname: alfa; fidtype: stp; fnext: ctp; fival: integer);
BEGIN (*ENTERSTDID*)
new(cp);
WITH cp↑ DO
BEGIN
klass := fidclass; name := fname; idtype := fidtype; next := fnext;
IF fidclass = konst THEN values.ival := fival
END;
enterid(cp)
END (*ENTERSTDID*);
BEGIN (*ENTERSTDNAMES*)
enterstdid(types,'INTEGER ',intptr,NIL,0);
enterstdid(types,'REAL ',realptr,NIL,0);
enterstdid(types,'CHAR ',charptr,NIL,0);
enterstdid(types,'ASCII ',asciiptr,NIL,0);
enterstdid(types,'BOOLEAN ',boolptr,NIL,0);
enterstdid(types,'TEXT ',textptr,NIL,0);
enterstdid(types,'ALFA ',alfaptr,NIL,0);
enterstdid(konst,'NIL ',nilptr,NIL,377777B);
enterstdid(konst,'ALFALENGTH',intptr,NIL,10);
enterstdid(konst,'MAXINT ',intptr,NIL,377777777777B);
enterstdid(konst,'MININT ',intptr,NIL,-maxint - 1);
new(lcsp,reel); lcsp↑.intval := 377777777777B;
enterstdid(konst,'MAXREAL ',realptr,NIL,ord(lcsp));
new(lcsp,reel); lcsp↑.intval := 400000000B;
enterstdid(konst,'SMALLREAL ',realptr,NIL,ord(lcsp));
cp := NIL;
FOR i := 1 TO 2 DO
enterstdid(konst,na[stdconst,i],boolptr,cp,i-1);
WITH boolptr↑ DO
BEGIN
fconst := cp; vectoraddr := 0; vectorchain := 0;
tlev := 0; request := false; nextscalar := NIL;
dimension := 1
END;
declscalptr := boolptr;
cp := NIL;
FOR i := 3 TO 35 DO
enterstdid(konst,na[stdconst,i],asciiptr,cp,i-3);
enterstdid(konst,na[stdconst,36],asciiptr,cp,177B);
(* 25. STRING,STRGRANGE,STRGRANGE0,MAXSTRLEN,NULLSTR: FOR THE STRING PACKAGE.*)
IF stringpack THEN
BEGIN
enterstdid(types,'STRING ', sstringptr, NIL, 0);
enterstdid(types,'STRGRANGE ', strgrngptr, NIL, 0);
enterstdid(types,'STRGRANGE0', strgrng0ptr, NIL, 0);
enterstdid(konst,'MAXSTRLEN ', strgrngptr, NIL, 135);
new(lcsp,strg:140);
enterstdid(konst,'NULLSTR ', packc0ptr, NIL, ord(lcsp));
END;
(*INPUT,OUTPUT,TTY,TTYOUTPUT*)
%24 llc := locationofafile (input); (* 21.*) \
FOR i := 1 TO namax[stdfile] DO
BEGIN
new(cp,vars);
stdfileptr[i] := cp;
WITH cp↑ DO
BEGIN
name := na[stdfile,i]; idtype := textptr; channel := i-1;
vkind := actual; next := NIL; vlev := 0;
%13 (* 20.*)
vaddr:= lc;
lc:=lc+idtype↑.size;
(* 20.*) \
%24 (* 20.*)
vaddr := llc;
llc := llc + idtype↑.size;
filelc := filelc + idtype↑.size;
(* 20.*) \
new(lfileptr) ;
WITH lfileptr↑ DO
BEGIN
nextftp := fileptr ;
fileident := cp
END ;
fileptr := lfileptr
END;
enterid(cp)
END;
(* GET,GETLN,PUT,PUTLN,RESET,REWRITE,READ,READLN,
WRITE,WRITELN,PACK,UNPACK,NEW,GETLINR,
PAGE,PROTECTION,RUN,DATE,TIME,DISPOSE,
HALT,GETSEG,PUTSEG,MESSAGE,LINELIMIT*)
FOR i := 1 TO namax[stdproc] DO
BEGIN
new(cp,proc,standard);
WITH cp↑ DO
BEGIN
name := na[stdproc,i]; idtype := NIL;
next := NIL; key := i
END;
enterid(cp)
END;
(* CLOCK,ABS,SQR,ODD,ORD,CHR,PRED,SUCC,EOF,EOLN,REALTIME,CARD,
LOWERBOUND,UPPERBOUND,MIN,MAX,FIRST,LAST,EOS*)
FOR i := 1 TO namax[stdfunc] DO
BEGIN
new(cp,func,standard);
WITH cp↑ DO
BEGIN
name := na[stdfunc,i]; idtype := NIL;
next := NIL; key := i
END;
enterid(cp)
END;
(* COS,EXP,SQRT,ALOG,ATAN,ALOG10,
SIND,COSD,SINH,COSH,TANH,ASIN,ACOS,RAN,SIN*)
enterstdparameter(realptr,actual,NIL,2);
FOR i := 1 TO 15 DO enterstdprocfunc(i,func,realptr,cp);
(* ROUND, EXPO *)
enterstdprocfunc(16,func,intptr,cp);
enterstdprocfunc(17,func,intptr,cp);
(* OPTION *)
enterstdparameter(alfaptr,actual,NIL,2);
enterstdprocfunc(18,func,boolptr,cp);
(* TRUNC *)
enterstdparameter(realptr,actual,NIL,2);
enterstdprocfunc(20,func,intptr,cp);
(* GETFILENAME *)
enterstdparameter(alfaptr,actual,NIL,6);
enterstdparameter(packc6ptr,formal,cp,5);
enterstdparameter(intptr,formal,cp,4);
enterstdparameter(intptr,formal,cp,3);
enterstdparameter(packc9ptr,formal,cp,2);
enterstdparameter(anyfileptr,formal,cp,1);
enterstdprocfunc(1,proc,NIL,cp);
(* GETOPTION *)
enterstdparameter(intptr,formal,NIL,4);
enterstdparameter(alfaptr,actual,cp,2);
enterstdprocfunc(2,proc,NIL,cp);
(* GETSTATUS *)
enterstdparameter(packc6ptr,formal,NIL,5);
enterstdparameter(intptr,formal,cp,4);
enterstdparameter(intptr,formal,cp,3);
enterstdparameter(packc9ptr,formal,cp,2);
enterstdparameter(anyfileptr,formal,cp,1);
enterstdprocfunc(3,proc,NIL,cp);
(* 7. KNOW ABOUT NEW RUNTIMES IN CCL SCANNER.*)
(*ASKFILENAME*)
enterstdparameter (asciiptr, formal, NIL, 11);
enterstdparameter (boolptr, formal, cp, 10);
enterstdparameter (boolptr, actual, cp, 9);
enterstdparameter (alfaptr, actual, cp, 7);
enterstdparameter (alfaptr, actual, cp, 5);
enterstdparameter (packc6ptr, formal, cp, 4);
enterstdparameter (intptr, formal, cp, 3);
enterstdparameter (intptr, formal, cp, 2);
enterstdparameter (packc9ptr, formal, cp, 1);
enterstdprocfunc (4, proc, NIL, cp);
(*STARTFILE*)
enterstdparameter (packc3ptr, actual, NIL, 9);
enterstdparameter (alfaptr, actual, cp, 7);
enterstdparameter (boolptr, actual, cp, 6);
enterstdparameter (packc6ptr, formal, cp, 5);
enterstdparameter (intptr, formal, cp, 4);
enterstdparameter (intptr, formal, cp, 3);
enterstdparameter (packc9ptr, formal, cp, 2);
enterstdparameter (anyfileptr, formal, cp, 1);
enterstdprocfunc (5,proc, NIL, cp);
(*GETPARAMETER*)
enterstdparameter (boolptr, actual, NIL, 4);
enterstdparameter (alfaptr, formal, cp, 3);
enterstdparameter (alfaptr, formal, cp, 2);
enterstdparameter (anyfileptr, formal, cp, 1);
enterstdprocfunc (6, proc, NIL, cp);
(*GETNEXTCALL*)
enterstdparameter (packc6ptr, formal, NIL, 2);
enterstdparameter (packc9ptr, formal, cp, 1);
enterstdprocfunc (7, proc, NIL, cp);
(*FILNAM*)
enterstdparameter (boolptr, formal, NIL, 9);
enterstdparameter (boolptr, formal, cp, 8);
enterstdparameter (boolptr, actual, cp, 7);
enterstdparameter (alfaptr, actual, cp, 5);
enterstdparameter (packc6ptr, formal, cp, 4);
enterstdparameter (intptr, formal, cp, 3);
enterstdparameter (packc9ptr, formal, cp, 2);
enterstdparameter (anyfileptr, formal, cp, 1);
enterstdprocfunc (8, proc, NIL, cp);
(*REENTER, SETTIME*)
enterstdprocfunc (9, proc, NIL, NIL);
enterstdprocfunc (10, proc, NIL, NIL);
(*TIMEREPORT*)
enterstdparameter (alfaptr, actual, NIL, 2);
enterstdparameter (anyfileptr, formal, cp, 1);
enterstdprocfunc (11, proc, NIL, cp);
(*RUNTIME*)
enterstdparameter (alfaptr, formal, NIL, 1);
enterstdprocfunc (12, proc, NIL, cp);
(*ELAPSEDTIME*)
enterstdparameter (alfaptr, formal, NIL, 1);
enterstdprocfunc (13, proc, NIL, cp);
(* 25. FOR THE STRING PACKAGE: *)
IF stringpack THEN
BEGIN
(* LENGTH *)
enterstdparameter(sstringptr,actual,NIL,2);
enterstdprocfunc(21,func,strgrngptr,cp);
(* GETCHAR *)
enterstdparameter(strgrngptr,actual,NIL,30);
enterstdparameter(sstringptr,actual,cp,2);
enterstdprocfunc(22,func,charptr,cp);
(* POS *)
enterstdparameter(sstringptr,actual,NIL,30);
enterstdparameter(sstringptr,actual,cp,2);
enterstdprocfunc(23,func,intptr,cp);
(* STRLT, STRLE, STREQ, STRGE, STRGT, STRNE *)
FOR i := 24 TO 29 DO
BEGIN
enterstdparameter(sstringptr,actual, NIL,30);
enterstdparameter(sstringptr,actual,cp,2);
enterstdprocfunc(i,func,boolptr,cp);
END;
(* PUTCHAR *)
enterstdparameter(strgrngptr,actual,NIL,3);
enterstdparameter(sstringptr,formal,cp,2);
enterstdparameter(charptr,actual,cp,1);
enterstdprocfunc(14,proc,NIL,cp);
(* ASSIGN *)
enterstdparameter(sstringptr,formal,NIL,29);
enterstdparameter(sstringptr,actual,cp,1);
enterstdprocfunc(15,proc,NIL,cp);
(* SUBSTR *)
enterstdparameter(intptr,actual,NIL,32);
enterstdparameter(intptr,actual,cp,31);
enterstdparameter(intptr,actual,cp,30);
enterstdparameter(sstringptr,formal,cp,29);
enterstdparameter(sstringptr,actual,cp,1);
enterstdprocfunc(16,proc,NIL,cp);
(* CONCAT *)
enterstdparameter(sstringptr,formal,NIL,29);
enterstdparameter(sstringptr,actual,cp,1);
enterstdprocfunc(17,proc,NIL,cp);
END;
(* SETRAN *)
enterstdparameter(intptr,actual,NIL,1);
enterstdprocfunc(18,proc,NIL,cp);
sexternpfptr := externpfptr;
sfileptr := fileptr;
sdeclscalptr := declscalptr;
lcmain := lc
END (*ENTERSTDNAMES*) ;
PROCEDURE enterundecl;
VAR
i: integer;
BEGIN (*ENTERUNDECL*)
new(utypptr,types);
WITH utypptr↑ DO
BEGIN
name := ' '; idtype := NIL; next := NIL
END;
new(ucstptr,konst);
WITH ucstptr↑ DO
BEGIN
name := ' '; idtype := NIL; next := NIL;
values.ival := 0
END;
new(uvarptr,vars);
WITH uvarptr↑ DO
BEGIN
name := ' '; idtype := NIL; vkind := actual;
next := NIL; vlev := 0; vaddr := 0
END;
new(ufldptr,field);
WITH ufldptr↑ DO
BEGIN
name := ' '; idtype := NIL; next := NIL; fldaddr := 0;
packf := notpack
END;
new(uprcptr,proc,declared,actual);
WITH uprcptr↑ DO
BEGIN
name := ' '; idtype := NIL; forwdecl := false;
FOR i := 0 TO maxlevel DO linkchain[i] := 0;
next := NIL; externdecl := false; pflev := 0; pfaddr := 0
END;
new(ufctptr,func,declared,actual);
WITH ufctptr↑ DO
BEGIN
name := ' '; idtype := NIL; next := NIL;
FOR i := 0 TO maxlevel DO linkchain[i] := 0;
forwdecl := false; externdecl := false; pflev := 0; pfaddr := 0
END
END (*ENTERUNDECL*) ;
(*get←directives*)
PROCEDURE get←directives;
(* 23. USE THE PROCEDURES FROM THE LIBRARY, TO GUARANTEE CONSISTENCY OF FUTURE CHANGES.*)
const
%13 myname = 'pascal '; \
%24 myname = 'passgo '; \
VAR
%13 object←protection , object←ufd, (* 14.*) \
source←protection , source←ufd: integer;
%13 object←device: packed array[1..6] of char; (* 14.*) \
fromtmpfile: boolean;
brkchar: char;
%24 lastch: char; (* 14.*) \
BEGIN (*GET←DIRECTIVES*)
%13 (* 14.*)
askfilename(object←file,object←protection,object←ufd,object←device, (* GET THE FILE NAMES.*)
'OBJECT ',myname,false,fromtmpfile,brkchar);
(* 14.*) \
%3 if brkchar <> '=' then begin \
askfilename(list←file,list←protection,list←ufd,list←device,
'LIST ',myname,false,fromtmpfile,brkchar);
%3 end
else
begin
list←file := ' '; list←device := 'dsk ';
end;
\
%2 if brkchar = ',' then
askfilename(list←file,list←protection,list←ufd,list←device,
'LIST ',myname,false,fromtmpfile,brkchar);
\
askfilename(source←file,source←protection,source←ufd,source←device,
'SOURCE ',myname,true,fromtmpfile,brkchar);
IF (source←file[1] = ' ') AND (source←device = 'DSK ') THEN (* OPEN SOURCE FILE.*)
source←file := 'SOURCE ';
startfile (source, source←file, source←protection, source←ufd,
source←device, true, 'SOURCE ', %13 'PAS' \ %24 'PGO' \ );
%13 (* 14.*) (* 11. DEFAULT THE OBJECT FILE NAME IF NEEDED.*)
IF (object←file [1] = ' ') AND (object←device = 'DSK ') THEN (* OPEN OBJECT FILE.*)
IF source←file = 'SOURCE ' THEN
object←file := 'OBJECT '
ELSE
FOR i := 1 TO 6 DO
object←file[i] := source←file[i];
startfile(object,object←file,object←protection,object←ufd,
object←device,false,'OBJECT ','REL');
(* 14.*) \
cross←reference := option('CREF ') OR option('C ') ; (* OPEN LIST FILE, IF REQUESTED.*)
counting := option('PROFILE ') OR option('KNT ') or option ('k '); (* 28.*)
%13 cross←reference := cross←reference AND NOT counting; \
%24 cross←reference := cross←reference OR counting; \
%13 list←code := option('CODE '); (* 14.*) \
logfile := option ('log ');
lptfile := NOT option('NOLIST ') AND (NOT cross←reference) AND
(NOT counting) AND
( %13 list←code OR (* 14.*) \
option('LPT ') OR
option('LIST ') OR
(list←file <> ' ') OR
(list←device <> 'DSK ')); (* 9.*)
(* 11. DEFAULT THE LIST FILE NAME IF NEEDED.*)
IF lptfile THEN
BEGIN
IF (list←file [1] = ' ') AND (list←device = 'DSK ') THEN
FOR i := 1 TO 6 DO
list←file[i] := source←file[i];
startfile(list,list←file,list←protection,list←ufd,list←device,
false,'LIST ','LST');
logfile := false;
END
else
if logfile then
begin
for i := 1 to 6 do
list←file[i] := source←file[i];
list←file[7] := 'l'; list←file[8] := 'o'; list←file[9] := 'g';
startfile(list,list←file,list←protection,list←ufd,list←device,
false,'LOGFILE ','LOG');
end;
debug := option('DEBUG ') OR option ('D '); (* 13.*) (* CHECK SWITCHES.*)
debug←switch := debug;
runtime←check := NOT option('NOCHECK ');
genprocfile := option('prc ');
resettty := NOT option ('NOTTY ');
openoutput := NOT option ('NOOUTPUT ');
IF option('CODESIZE ') THEN getoption('CODESIZE ',code←size);
IF option('REGISTER ') THEN
BEGIN
getoption('REGISTER ',i);
IF i IN [regin..within] THEN parregcmax := i
END;
(* 8. ALLOW FOR SWITCH /VERSION.*)
IF option ('VERSION ') THEN
getoption ('VERSION ',goodversion);
%13 (* 14. SWITCHES PARTICULAR TO PASCAL AND ITS VERSION OF LOAD←AND←GO CHECKING.*)
fortran←enviroment := option('FORTIO ');
external := option('EXTERN ');
IF option('RUNCORE ') THEN getoption('RUNCORE ',runcore);
IF option('CARD ') THEN chcntmax := 72;
IF option('FILE ') THEN
BEGIN
getoption('FILE ',i);
IF i IN [1..max←file] THEN start←channel := i + namax[stdfile] - 2
END;
(* 1. IF A LINKER NAME CAME IN THE TEMPCORE FILE, LOAD←AND←GO.*)
IF fromtmpfile THEN (* ONLY IF A TMPCORE FILE WAS SUPPLIED.*)
begin
getnextcall(linker←file,link←device);
IF linker←file = 'LOADER ' THEN
BEGIN
\
%3 link←device := 'sys '; \
%13
loadit := true;
link←tmpfile := 'LOA TMP';
END
ELSE
BEGIN
IF (linker←file = 'LINK ') OR (linker←file = 'LINK10 ') THEN
BEGIN
\
%3 link←device := 'sys '; \
%13
loadit := true;
link←tmpfile := 'LNK TMP';
END
ELSE (* NO LEGAL LINKER NAME.*)
link←tmpfile := ' ';
END;
end;
load←and←go := option('EXECUTE ') OR (counting AND NOT option ('NOEXECUTE '));
loadit := loadit OR (option ('LINK ') OR
load←and←go OR option ('LOAD '))
AND NOT external;
\
% 3
load←and←go := (not external) and (not option ('nolink '))
and (option('link ') or option('loader '));
if option('loader ') then
begin
linker←file := 'loader ';
link←tmpfile := 'loa tmp';
end
else
begin
linker←file := 'link ';
link←tmpfile := 'lnk tmp'
end;
\
%13
reset(tempcore,link←tmpfile); (* CHECK FOR THE DEBUG SWITCH IN THE TEMPFILE FOR THE LINKER *)
IF NOT eof(tempcore) THEN
BEGIN
new(command←buffer:buffer←size);
command←buffer↑[0] := ' '; i := 1;
WHILE NOT eof(tempcore) AND (i < buffer←size) DO
BEGIN
IF eoln(tempcore) THEN
BEGIN
readln(tempcore);
command←buffer↑[i] := cr;
command←buffer↑[i+1] := lf; i := i + 2
END
ELSE (* NOT EOLN(TEMPCORE) *)
BEGIN
read(tempcore,ch);
command←buffer↑[i] := ch;
IF (command←buffer↑[i-1] = '/') AND (ch = 'D') THEN
BEGIN
debug := true; debug←switch := true;
(* 13. GET RID OF THE REST OF THE STANDARD SWITCH, /DEBUG:PASCAL*)
WHILE ch IN ['A'..'Z',':'] DO
read (tempcore, ch);
command←buffer↑[i-1] := ch;
END
ELSE i := i + 1
END
END;
rewrite(tempcore,link←tmpfile);
write(tempcore,command←buffer↑:i);
dispose(command←buffer:buffer←size)
END
ELSE (* EOF(TEMPCORE) *)
BEGIN
IF loadit THEN
BEGIN
rewrite(tempcore,link←tmpfile); (* 1. FLEXIBLE NAME OF LINKER.*)
write(tempcore,'DSK:',object←file:6);
IF load←and←go THEN
write(tempcore,' /E');
write(tempcore,'/G'); (* 1. MORE CORRECT ORDERING.*)
END
END;
(* 14.*) \
%24 (* 14. PASSGO VERSION OF THE LOAD←AND←GO CHECKING.*)
IF fromtmpfile THEN
BEGIN
getnextcall(linker←file, link←device); (* SEE IF ANY LOADER WAS INVOKED *)
IF linker←file = ' ' THEN
no←code←gen := true
ELSE
BEGIN
IF (linker←file = 'LOADER ') OR (linker←file = 'LOADEREXE') THEN
link←tmpfile := 'LOA TMP'
ELSE
IF (linker←file[1] = 'L') AND (linker←file[2] = 'I') AND
(linker←file[3] = 'N') AND (linker←file[4] = 'K') THEN
link←tmpfile := 'LNK TMP';
reset(tempcore,link←tmpfile); (* CHECK FOR THE DEBUG SWITCH IN THE TEMPFILE FOR THE LOADER *)
IF NOT eof(tempcore) THEN
BEGIN
lastch := ' ';
WHILE NOT eof(tempcore) DO
BEGIN
IF eoln(tempcore) THEN
readln(tempcore)
ELSE (* NOT EOLN(TEMPCORE) *)
BEGIN
read(tempcore,ch);
IF (lastch = '/') AND (ch = 'D') THEN
BEGIN
debug := true; debug←switch := true;
END;
lastch := ch;
END
END;
END
END;
END;
(* 14.*) \
END (*GET←DIRECTIVES*);
procedure startlog;
begin
end (*startlog*);
(* COMPILE[ newpager, writebuffer, getnextline, finishline, error←with←text, warning*)
PROCEDURE compile;
LABEL
111;
VAR
escape: boolean;
PROCEDURE newpager;
BEGIN (*NEWPAGER*)
WITH pager, word1 DO
BEGIN
ac := pagecnt DIV 16;
inxreg := pagecnt MOD 16; address := lastpager;
lhalf := lastline; rhalf := laststop;
lastline := -1
END
END (*NEWPAGER*);
%13 (* 14. LIST←CODE IS NOT IN PASSGO.*)
PROCEDURE writebuffer;
BEGIN (*WRITEBUFFER*)
IF list←code THEN
BEGIN
writeln(list,buffer:chcnt); FOR chcnt := 1 TO 17 DO buffer[chcnt] := ' ';
chcnt := 17
END
END (*WRITEBUFFER*);
(* 14.*) \
PROCEDURE getnextline;
BEGIN (*GETNEXTLINE*)
LOOP
getlinenr(source,linenr);
if reset←possible then
if linenr = '-----' then
hassoslines := false;
EXIT IF (linenr <> ' ') OR eof(source);
linecnt := 1;
IF debug AND (lastline > -1) THEN newpager;
pagecnt := pagecnt + 1;
IF lptfile THEN
BEGIN
page(list); writeln(list,header,' COMPILATION LIST PRODUCED ON ',day,
' AT ',timeofday,' PAGE ',pagecnt:3); writeln(list)
END;
(* 6. GIVE PAGENUMBERS ON TTY.*)
IF programname <> ' ' THEN
write (tty, pagecnt:3, '..');
break (tty);
error←in←heading := true;
readln(source) (*TO OVERREAD SECOND <LF> IN PAGE MARK*)
END;
%13 (* 14. LIST←CODE IS NOT IN PASSGO.*)
IF list←code THEN
BEGIN
IF dp THEN write(list,lc:6:o,showrelo[(lc >= low←start) AND (level <= 1)])
ELSE write(list,ic:6:o,'''');
write(list,' ':2)
END;
(* 14.*) \
IF lptfile THEN
BEGIN
IF not hassoslines THEN write(list,linecnt:5)
ELSE write(list,linenr) ;
write(list,' ':3)
END
END (*GETNEXTLINE*);
PROCEDURE finishline;
VAR
llptfile: boolean;
i,k: integer;
BEGIN (*finishline*)
tchcnt := tchcnt + chcnt;
IF chcnt > chcntmax THEN chcnt := chcntmax;
IF lptfile THEN writeln(list,buffer:chcnt);
IF errorinline THEN (*OUTPUT ERROR MESSAGES*)
BEGIN
IF error←in←heading THEN
BEGIN
writeln(tty);
error←in←heading := false;
END;
%13 (* 14.*)
IF list←code THEN
k := 11
ELSE
(* 14.*) \
k := 2;
IF lptfile THEN writeln(list,' ':k,'***** ',errline : chcnt)
else
if logfile then
begin
if hassoslines then
write(list,linenr)
else
write(list,linecnt:5);
writeln(list,'/',pagecnt:2,' ',buffer:chcnt);
writeln(list,currname,errline:chcnt)
end;
%13 list←code := false; (* 14.*) \
IF not hassoslines THEN (* 27.*)
write(tty,linecnt:5)
ELSE write(tty,linenr);
(* 13.*)
writeln(tty,'/',pagecnt:2,' ',buffer:chcnt);
writeln(tty,currname,errline : chcnt);
llptfile := lptfile or logfile;
FOR k := 1 TO errinx DO
WITH errlist[k] DO
BEGIN
IF llptfile THEN write(list,' ':15,arw:1,'.',tic,': ');
write(tty,arw:1,'.',tic,': ');
IF errmptr <> NIL THEN
BEGIN
errmptr1 := errmptr;
REPEAT
WITH errmptr1↑ DO
IF nmr = number THEN
BEGIN
IF msgkind = intmsg THEN
BEGIN
IF llptfile THEN
write(list,intval,' - ');
write(tty,intval,' - ');
END
ELSE (*MSGKIND = ALFAMSG*)
BEGIN
IF llptfile THEN write(list,string:10,' - ');
write(tty,string:10,' - ');
END;
number := 0; errmptr1 := NIL
END
ELSE errmptr1 := next
UNTIL errmptr1 = NIL
END;
i := nmr MOD 50;
CASE nmr DIV 50 OF
3:
BEGIN
IF llptfile THEN write(list,errmess15[i]);
write(tty,errmess15[i])
END;
4:
BEGIN
IF llptfile THEN write(list,errmess20[i]);
write(tty,errmess20[i])
END;
5:
BEGIN
IF llptfile THEN write(list,errmess25[i]);
write(tty,errmess25[i])
END;
6:
BEGIN
IF llptfile THEN write(list,errmess30[i]);
write(tty,errmess30[i])
END;
7:
BEGIN
IF llptfile THEN write(list,errmess35[i]);
write(tty,errmess35[i])
END;
8:
BEGIN
IF llptfile THEN write(list,errmess40[i]);
write(tty,errmess40[i])
END;
9:
BEGIN
IF llptfile THEN write(list,errmess45[i]);
write(tty,errmess45[i])
END;
10:
BEGIN
IF llptfile THEN write(list,errmess50[i]);
write(tty,errmess50[i])
END;
11:
BEGIN
IF llptfile THEN write(list,errmess55[i]);
write(tty,errmess55[i])
END
END;
IF error←in←first THEN (* 30.*)
BEGIN
error←in←first := false;
IF llptfile THEN
write(list,' *** CHECK ALSO PREVIOUS LINE ***');
write(tty,' *** CHECK ALSO PREVIOUS LINE ***');
END;
IF llptfile THEN writeln(list);
writeln(tty)
END;
break(tty); errinx := 0; errorinline := false;
FOR i := 1 TO chcnt DO errline [i] := ' ';
errmptr := NIL
END;
readln(source);
linecnt := linecnt + 1; chcnt := 0; symcnt :=0;
IF programname <> ' ' THEN (* 27.*)
IF linecnt MOD 500 = 0 THEN
BEGIN
write(tty,'(',linecnt:5,')');
break(tty);
error←in←heading := true;
END;
IF error←exit THEN
IF first←symbol THEN GOTO 0
ELSE GOTO 111
ELSE
BEGIN
IF NOT eof(source) THEN getnextline
ELSE
BEGIN
IF NOT first←symbol THEN error(267);
error←exit := true;
finishline
END
END
END (*finishline*) ;
PROCEDURE error←with←text ( ferrnr: integer; ftext: alfa ) ;
BEGIN (*ERROR←WITH←TEXT*)
error(ferrnr); new(errmptr1,alfamsg);
WITH errmptr1↑ DO
BEGIN
number := ferrnr; string := ftext;
next := errmptr
END;
errmptr := errmptr1
END (*ERROR←WITH←TEXT*) ;
PROCEDURE error←valued(ferrnr, fint: integer);
BEGIN (*ERROR←VALUED*)
error(ferrnr); new(errmptr1,intmsg);
WITH errmptr1↑ DO
BEGIN
number := ferrnr; intval := fint;
next := errmptr;
END;
errmptr := errmptr1;
END (*ERROR←VALUED*);
PROCEDURE warning (ferrnr: integer);
BEGIN (* WARNING *)
error←with←text (ferrnr,' WARNING: ');
errorcount := errorcount - 1;
IF errorcount = 0 THEN
error←flag := false;
END (* WARNING *);
(*insymbol[nextch, skipcomment[options], skip←e←directory*)
PROCEDURE insymbol;
(*READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS
DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH*)
LABEL
111,
222;
CONST
maxdigits = 12;
max8 = 37777777777B;
test8 = 40000000000B;
max10 = 3435973836; (* MAXINT = 2 ** 35 - 1 = 34.359.738.367 *)
max16 = 17777777777B;
test16 = 20000000000B;
maxexp2 = 127; (* MAXREAL = 777.777.777B * 2 ** 100 *)
log←of←2 = 0.30102999806;
VAR
i, k, scale, exponent, ival: integer;
rval, r, fac: real;
stringtoolong, sign: boolean;
digit: ARRAY [1..maxdigits] OF 0..9;
string: ARRAY [1..strglgth] OF char;
lvp: csp;
PROCEDURE nextch;
BEGIN (*NEXTCH*)
IF eoln(source) THEN ch := ' '
ELSE
BEGIN
ch := source↑; get(source);
chcnt := chcnt + 1;
IF chcnt <= chcntmax THEN buffer[chcnt] := ch
ELSE
IF chcntmax = 72 THEN nextch
END
END (*NEXTCH*);
(* 3. DISTINGUISH ONE-CHAR FROM TWO-CHAR LONG END OF COMMENT.*)
PROCEDURE skipcomment (onechar: boolean; endchar: char);
VAR
lcondcomp,
commentend: boolean;
PROCEDURE options;
VAR
lch : char;
lswitch : boolean;
lvalue : integer;
BEGIN (*OPTIONS*)
REPEAT
lvalue := 0; lswitch := false;
nextch; lch := ch;
IF NOT (ch IN ['\','*']) THEN nextch;
IF ch IN (['+','-'] + digits) THEN
BEGIN
IF ch IN ['+','-'] THEN
BEGIN
lswitch := ch = '+'; nextch
END
ELSE
REPEAT
lvalue := lvalue * 10 + (ord(ch)-ord('0'));
nextch
UNTIL NOT (ch IN digits);
IF NOT reset←possible AND (lch IN ['S','R','X','F','I','U','E','V','Y','C','O','G']) then
error(203)(* 8. ALLOW FOR OPTION V AND Y.*) (* 28.*)
else
CASE lch OF
%13 (* 14. SUPPRESSED FOR PASSGO.*)
'L':
list←code := lswitch AND lptfile;
'U':
IF lswitch THEN (* 13. ONLY IF IT IS 'U+'.*)
chcntmax := 72;
(* 14.*) \
'G':
if lswitch and not logfile and not lptfile then
begin
logfile := true;
for i := 1 to 6 do
list←file[i] := source←file[i];
list←file[7] := 'l'; list←file[8] := 'o'; list←file[9] := 'g';
startfile(list,list←file,list←protection,list←ufd,list←device,
false,'LOGFILE ','LOG');
end;
'T':
runtime←check := lswitch;
%13 (* 14. SUPPRESSED FOR PASSGO. *)
'E':
IF program←count > 1 THEN error(203)
ELSE
BEGIN
external := lswitch;
IF external THEN (* 13. CANCEL LOAD←AND←GO.*)
load←and←go := false;
END;
(* 14.*) \
'D' %13 ,'P' \ : (* 14.*)
IF reset←possible THEN
BEGIN
debug := lswitch;
debug←switch := lswitch
END
ELSE
IF debug THEN debug←switch := lswitch
ELSE error(203);
%13 (* 14. SUPPRESSED FOR PASGO.*)
'F':
IF lvalue IN [1..max←file] THEN start←channel := lvalue + namax[stdfile] - 2
ELSE error(203);
'R':
runcore := lvalue;
(* 14.*) \
'X':
IF lvalue IN [regin..within] THEN parregcmax := lvalue
ELSE error(203);
'S':
code←size := lvalue;
%13 (* 14. SUPPRESSED FOR PASSGO.*)
'I':
fortran←enviroment := lswitch;
(* 14.*) \
(* 8. SET THE VERSION NUMBER.*)
'V':
goodversion := lvalue;
'C': (* 28.*)
counting := lswitch;
%13
'Y':
resettty := lswitch;
'O':
openoutput := lswitch;
\
OTHERS:
IF lch %13 = 'B' (* 14.*) \
%24 IN ['B','E','F','I','L','P','R','U','Y','O'] (* 14.*) \ THEN
warning(169)
ELSE error(203)
END
END
ELSE error(203);
IF eoln(source) THEN finishline
UNTIL ch <> ','
END (*OPTIONS*) ;
BEGIN (*SKIPCOMMENT*)
commentend := false; nextch; lcondcomp := false;
IF ch = '$' THEN options;
(* 3. TREAT '%'-'\' COMMENTS DIFFERENTLY.*)
IF onechar THEN
begin
while ch in digits do
begin
if ord(ch)-ord('0')=goodversion then
lcondcomp := true;
nextch;
end;
incondcomp := incondcomp or lcondcomp;
if not lcondcomp then
WHILE ch <> endchar DO
BEGIN
IF eoln (source) THEN
finishline;
nextch;
END
end (*if onechar*)
ELSE
LOOP
WHILE ch = '*' DO
BEGIN
nextch;
commentend := ch = ')'
END
EXIT IF commentend; (* 3.*)
IF eoln(source) THEN finishline;
nextch
END (*LOOP*);
nextch
END (*SKIPCOMMENT*);
%34
procedure skip←e←directory;
begin (*skip←e←directory*)
while not (ch = ';') do
begin
if eoln(source) then
finishline;
nextch;
end;
nextch;
end (*skip←e←directory*);
\
BEGIN (*INSYMBOL*)
111: (* 2. *)
WHILE ch = ' ' DO
BEGIN
IF eoln(source) THEN finishline;
nextch
END;
CASE ch OF
'%':
BEGIN
skipcomment (true,'\'); GOTO 111;
END;
%34
'"': (*SAIL way of making comments*)
begin
skipcomment (true,'"'); goto 111;
end;
'#': (*please, god, forgive me!*)
begin
while ch = '#' do
nextch;
if eoln(source) then
finishline;
goto 111;
end;
\
'(':
BEGIN
nextch;
IF ch = '*' THEN
BEGIN
skipcomment (false,' '); GOTO 111; (* 2.,3.*)
END
ELSE
BEGIN
sy := lparent; op := noop
END
END;
'A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y',
'Z':
BEGIN
k := 0 ; id := ' ';
REPEAT
IF k < alfalength THEN
BEGIN
k := k + 1; id[k] := ch
END ;
nextch
UNTIL NOT (ch IN lettersdigitsorleftarrow);
%34
if first←symbol and (id = 'comment ') then
begin
skip←e←directory;
goto 111;
end;
\
FOR i := frw[k] TO frw[k+1] - 1 DO
IF rw[i] = id THEN
BEGIN
sy := rsy[i];
op := rop[i];
IF (sy = initprocsy) AND NOT dp THEN error(363);
GOTO 222
END;
sy := ident; op := noop;
222:
END;
'0','1','2','3','4','5','6','7','8',
'9':
BEGIN
sy := intconst; op := noop;
id := ' ';
i := 0;
REPEAT
i := i + 1;
(* THE DIGITS OF AN "INTCONST" ARE STORED AS "IDENT" TOO. THIS ALLOWES
TO ENTER "LABELS" LIKE ALL OTHER IDENTIFIERS INTO THE BINARY-
(IDENTIFIER-)TREE VIA "ENTERID" AND LOCATE THEM VIA
"SEARCHID". SO "LABELS" ARE "KNOWN" AS CONSTANTS, TYPES OR
VARIABLES IN THE BLOCK THEY HAVE BEEN DECLARED IN.
IT IS ALSO POSSIBLE TO "EXIT" FROM A BLOCK, JUMPING TO A LABEL
WHICH IS DECLARED ON A LOWER LEVEL *)
IF i <= alfalength THEN id[i] := ch;
IF i <= maxdigits THEN digit[i] := ord(ch) - ord('0')
ELSE error(174) ;
nextch
UNTIL NOT (ch IN digits);
ival := 0;
IF ch = 'B' THEN
BEGIN
FOR k := 1 TO i DO
IF ival <= max8 THEN
BEGIN
IF digit[k] IN [8,9] THEN error(252);
ival := 8*ival + digit[k]
END
ELSE
IF (ival = test8) AND (digit[12] = 0) THEN ival := -maxint - 1
ELSE
BEGIN
error(204); ival := 0
END;
val.ival := ival;
nextch
END
ELSE
BEGIN
FOR k := 1 TO i DO
IF ival <= max10 THEN
IF (ival = max10) AND (digit[k] > 7) THEN
BEGIN
error(204); ival := 0
END
ELSE ival := 10*ival + digit[k]
ELSE
BEGIN
error(204); ival := 0
END;
scale := 0;
IF ch = '.' THEN
BEGIN
nextch;
IF ch = '.' THEN ch := ':'
ELSE
BEGIN
rval := ival; sy := realconst;
IF NOT (ch IN digits) THEN error(205)
ELSE
REPEAT
rval := 10.0*rval + (ord(ch) - ord('0'));
scale := scale - 1; nextch
UNTIL NOT (ch IN digits)
END
END;
IF ch = 'E' THEN
BEGIN
IF scale = 0 THEN
BEGIN
rval := ival; sy := realconst
END;
nextch;
sign := ch='-';
IF (ch='+') OR sign THEN nextch;
exponent := 0;
IF NOT (ch IN digits) THEN error(205)
ELSE
REPEAT
exponent := 10 * exponent + ord(ch) - ord('0');
nextch
UNTIL NOT (ch IN digits);
IF sign THEN scale := scale - exponent
ELSE scale := scale + exponent;
IF abs(round(scale/log←of←2 + expo(rval))) >= maxexp2 THEN
BEGIN
error(206); scale := 0
END
END;
IF scale <> 0 THEN
BEGIN
IF scale < 0 THEN
BEGIN
scale := abs(scale); fac := 0.1
END
ELSE fac := 10.0;
r := 1.0;
LOOP
IF odd(scale) THEN r := r * fac;
scale := scale DIV 2
EXIT IF scale = 0;
fac := sqr(fac)
END;
rval := rval * r (* RVAL := RVAL * 10 ** SCALE *)
END;
IF sy = intconst THEN val.ival := ival
ELSE
BEGIN
new(lvp,reel);
lvp↑.rval := rval; val.valp := lvp
END
END
END;
%12 '"': \
%34 '!': \
BEGIN
sy := intconst; op := noop; ival := 0;
nextch;
WHILE (ch IN hexadigits) AND (ival >= 0) DO
BEGIN
IF ival <= max16 THEN
IF ch IN digits THEN ival := 16*ival + (ord(ch) - ord('0'))
ELSE ival := 16*ival + (ord(ch) - 67B)
ELSE
IF (ival = test16) AND (ch = '0') THEN ival := -maxint - 1
ELSE
BEGIN
error(174); ival := 0
END;
nextch
END;
WHILE ch IN hexadigits DO nextch;
val.ival := ival
END;
'''':
BEGIN
lgth := 0; sy := stringconst; op := noop; stringtoolong := false;
REPEAT
REPEAT
nextch;
IF lgth <= strglgth THEN
BEGIN
lgth := lgth + 1;
IF lgth <= strglgth THEN string[lgth] := ch
END
ELSE stringtoolong := true
UNTIL eoln(source) OR (ch = '''');
IF stringtoolong THEN error(301);
IF ch <> '''' THEN error(351)
ELSE nextch
UNTIL ch <> '''';
lgth := lgth - 1;
IF lgth = 1 THEN val.ival := ord(string[1])
ELSE
BEGIN
new(lvp,strg:lgth);
WITH lvp↑ DO
BEGIN
slgth := lgth;
pack(string,1,sval,1,lgth)
END;
val.valp := lvp
END
END;
':':
BEGIN
op := noop; nextch;
IF ch = '=' THEN
BEGIN
sy := becomes; nextch
END
ELSE sy := colon
END;
'.':
BEGIN
op := noop; nextch;
IF ch = '.' THEN
BEGIN
sy := colon; nextch
END
ELSE sy := period
END;
'<','>':
BEGIN
sy := relop; op := sop[ch]; nextch;
IF (op=ltop) AND (ch='>') THEN
BEGIN
op := neop; nextch
END
ELSE
IF ch = '=' THEN
BEGIN
IF op = ltop THEN op := leop
ELSE op := geop;
nextch
END
END;
(* 8. ALLOW THE '\' AT END OF A CONDITIONALY COMPILED PART.*)
'\':
IF incondcomp THEN
BEGIN
incondcomp := false;
nextch;
GOTO 111;
END
ELSE
BEGIN
sy := ssy[ch]; op := sop[ch];
nextch;
END;
OTHERS:
BEGIN
sy := ssy[ch]; op := sop[ch];
nextch
END
END (*CASE*);
first←symbol := false;
IF symcnt < 2 THEN (* 30.*)
symcnt := symcnt + 1;
END (*INSYMBOL*) ;
(*searchsection, searchid, skipiferr, iferrskip, errandskip*)
PROCEDURE searchsection(fcp: ctp; VAR fcp1: ctp);
(*TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S
--> PROCEDURE PROCEDUREDECLARATION
--> PROCEDURE SELECTOR*)
LABEL
333;
BEGIN (*SEARCHSECTION*)
WHILE fcp <> NIL DO
WITH fcp↑ DO
BEGIN
IF name = id THEN GOTO 333;
IF name < id THEN fcp := rlink
ELSE fcp := llink
END;
333:
fcp1 := fcp
END (*SEARCHSECTION*) ;
PROCEDURE searchid(fidcls: setofids; VAR fcp: ctp);
LABEL
444;
VAR
lcp: ctp;
BEGIN (*SEARCHID*)
FOR disx := top DOWNTO 0 DO
BEGIN
lcp := display[disx].fname;
WHILE lcp <> NIL DO
WITH lcp↑ DO
IF name = id THEN
IF klass IN fidcls THEN GOTO 444
ELSE
BEGIN
IF search←error THEN error(401);
lcp := rlink
END
ELSE
IF name < id THEN lcp := rlink
ELSE lcp := llink
END;
(*SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE
OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION
--> PROCEDURE SIMPLETYPE*)
IF search←error THEN
BEGIN
IF id[1] IN digits THEN error(215) (*UNDECLARED LABEL*)
ELSE error(253) (*UNDECLARED IDENTIFIER*);
(*TO AVOID RETURNING NIL, REFERENCE AN ENTRY
FOR AN UNDECLARED ID OF APPROPRIATE CLASS
--> PROCEDURE ENTERUNDECL*)
IF types IN fidcls THEN lcp := utypptr
ELSE
IF vars IN fidcls THEN lcp := uvarptr
ELSE
IF field IN fidcls THEN lcp := ufldptr
ELSE
IF konst IN fidcls THEN lcp := ucstptr
ELSE
IF proc IN fidcls THEN lcp := uprcptr
ELSE lcp := ufctptr
END;
444:
fcp := lcp
END (*SEARCHID*) ;
PROCEDURE skipiferr(fsyinsys:setofsys; ferrnr:integer; fskipsys: setofsys);
VAR
i,oldchcnt,oldlinecnt : integer;
BEGIN (*SKIPIFERR*)
IF NOT (sy IN fsyinsys) THEN
BEGIN
error(ferrnr);
oldlinecnt := linecnt; oldchcnt := chcnt;
WHILE NOT (sy IN fskipsys + fsyinsys) DO
BEGIN
(*SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND*)
IF oldlinecnt <> linecnt THEN oldchcnt := 1;
FOR i := oldchcnt TO chcnt-1 DO
IF i <= chcntmax THEN errline [i] := '*';
oldchcnt := chcnt; oldlinecnt := linecnt; errorinline := true;
insymbol
END
END;
followerror := false
END (*SKIPIFERR*);
PROCEDURE iferrskip(ferrnr: integer; fsys: setofsys);
BEGIN (*IFERRSKIP*)
skipiferr(fsys,ferrnr,fsys)
END (*IFERRSKIP*);
PROCEDURE errandskip(ferrnr: integer; fsys: setofsys);
BEGIN (*ERRANDSKIP*)
skipiferr([ ],ferrnr,fsys)
END (*ERRANDSKIP*);
(* BLOCK[ TYPE CHECKING: constant, getbounds, string, comptypes[checksstring[ismagic]] *)
PROCEDURE block(fprocp: ctp; fsys,leaveblocksys: setofsys);
TYPE
marker = ↑integer;
VAR
lsy: symbol; current←jump: 0..jump←max;
testpacked: boolean;
lcpar: addrrange;
heapmark, globmark: marker;
forward←procedures : ctp;
firstline,beginline: integer;
PROCEDURE constant(fsys: setofsys; VAR fsp: stp; VAR fvalu: valu);
VAR
lsp, lsp1: stp;
lcp: ctp;
sign: (none,pos,neg);
BEGIN (*CONSTANT*)
lsp := NIL; fvalu.ival := 0;
skipiferr(constbegsys,207,fsys);
IF sy IN constbegsys THEN
BEGIN
IF sy = stringconst THEN
BEGIN
IF lgth = 1 THEN lsp := asciiptr
ELSE
IF lgth = alfalength THEN lsp := alfaptr
ELSE
BEGIN
new(lsp,arrays); new(lsp1,subrange);
WITH lsp↑ DO
BEGIN
selfstp := NIL; aeltype := asciiptr; inxtype := lsp1;
size := (lgth+4) DIV 5; arraypf := true;
bitsize := bitmax
END;
WITH lsp1↑ DO
BEGIN
selfstp := NIL; size := 1; bitsize := bitmax;
vmin.ival := 1; vmax.ival := lgth; rangetype := intptr
END
END;
fvalu := val; insymbol
END
ELSE
BEGIN
sign := none;
IF (sy = addop) AND (op IN [plus,minus]) THEN
BEGIN
IF op = plus THEN sign := pos
ELSE sign := neg;
insymbol
END;
IF sy = ident THEN
BEGIN
searchid([konst],lcp);
WITH lcp↑ DO
BEGIN
lsp := idtype; fvalu := values
END;
IF sign <> none THEN
IF lsp = intptr THEN
BEGIN
IF sign = neg THEN fvalu.ival := -fvalu.ival
END
ELSE
IF lsp = realptr THEN
BEGIN
IF sign = neg THEN
fvalu.valp↑.rval := -fvalu.valp↑.rval
END
ELSE error(167);
insymbol
END
ELSE
IF sy = intconst THEN
BEGIN
IF sign = neg THEN val.ival := -val.ival;
lsp := intptr; fvalu := val; insymbol
END
ELSE
IF sy = realconst THEN
BEGIN
IF sign = neg THEN val.valp↑.rval := -val.valp↑.rval;
lsp := realptr; fvalu := val; insymbol
END
ELSE errandskip(168,fsys)
END;
iferrskip(166,fsys)
END;
fsp := lsp
END (*CONSTANT*) ;
PROCEDURE getbounds(fsp: stp; VAR fmin, fmax: integer); FORWARD;
FUNCTION string(fsp: stp) : boolean; FORWARD; (* 25.*)
FUNCTION comptypes(fsp1,fsp2: stp) : boolean;
(*DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE*)
VAR
nxt1,nxt2: ctp; comp: boolean; lmin,lmax,i: integer;
ltestp1,ltestp2: testp;
lsstrp: sstrptr; (* 25.*)
(* 25. TO KEEP THE LENGTH OF PACKED ARRAYS OF CHAR, FOR STRING PROCEDURE CALLS.*)
FUNCTION checksstring(fsp: stp) : boolean;
VAR
lmin, lmax: integer;
ok: boolean;
FUNCTION ismagic (name: alfa; fkind: namekind; ffirst,flast: integer) : boolean;
VAR
index: integer;
BEGIN (*ISMAGIC*)
ismagic := false;
index := ffirst;
WHILE index <= flast DO
IF name = na[fkind, index] THEN
BEGIN
ismagic := true;
index := flast + 1;
END
ELSE
index := index + 1;
END (*ISMAGIC*);
BEGIN (*CHECKSSTRING*)
checksstring := false;
IF pctp↑.klass = proc THEN
ok := ismagic(pctp↑.name,declproc,14,17) (* PUTCHAR TO CONCAT *)
ELSE
ok := ismagic(pctp↑.name,declfunc,21,29);
(* LENGTH TO STRNE *)
IF ok THEN
IF string(fsp) THEN
BEGIN
IF fsp↑.arraypf THEN
BEGIN
checksstring := true;
getbounds(fsp↑.inxtype,lmin,lmax);
sstringlength↑.value[sstringlength↑.count] := lmax-lmin+1;
END
END
ELSE
IF comptypes (fsp,asciiptr) THEN
BEGIN
checksstring := true;
sstringlength↑.value[sstringlength↑.count] := 1;
END;
END (*CHECKSSTRING*);
(* 25.*)
BEGIN (*COMPTYPES*)
(* 25. COUNT THE SSTRINGS THAT ARE CHECKED *)
IF stringpack THEN
IF parsingparameters THEN
IF (fsp1 = sstringptr) OR (fsp2 = sstringptr) THEN
IF NOT recall THEN
BEGIN
recall := true;
IF sstringstart THEN
BEGIN
new(lsstrp);
WITH lsstrp↑ DO
BEGIN
next := sstringlength; count := 0;
value[1] := xtrastrglgth; value[2] := xtrastrglgth;
END;
sstringlength := lsstrp;
sstringstart := false;
END;
sstringlength↑.count := sstringlength↑.count + 1;
END;
(* 25.*)
IF fsp1 = fsp2 THEN comptypes := true
ELSE
IF (fsp1 <> NIL) AND (fsp2 <> NIL) THEN
IF fsp1↑.form = fsp2↑.form THEN
CASE fsp1↑.form OF
scalar:
comptypes := false;
(* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
NOT RECOGNIZED TO BE COMPATIBLE*)
subrange:
comptypes := comptypes(fsp1↑.rangetype,fsp2↑.rangetype);
pointer:
BEGIN
comp := false; ltestp1 := globtestp; ltestp2 := globtestp;
WHILE ltestp1 <> NIL DO
WITH ltestp1↑ DO
BEGIN
IF (elt1 = fsp1↑.eltype) AND (elt2 = fsp2↑.eltype) THEN comp := true;
ltestp1 := lasttestp
END;
IF NOT comp THEN
BEGIN
new(ltestp1);
WITH ltestp1↑ DO
BEGIN
elt1 := fsp1↑.eltype;
elt2 := fsp2↑.eltype;
lasttestp := globtestp
END;
globtestp := ltestp1; comp := comptypes(fsp1↑.eltype,fsp2↑.eltype)
END;
comptypes := comp; globtestp := ltestp2
END;
power:
comptypes := comptypes(fsp1↑.elset,fsp2↑.elset);
arrays:
BEGIN
getbounds(fsp1↑.inxtype,lmin,lmax);
i := lmax-lmin;
getbounds(fsp2↑.inxtype,lmin,lmax);
comptypes := comptypes(fsp1↑.aeltype,fsp2↑.aeltype)
AND (fsp1↑.arraypf = fsp2↑.arraypf) AND ( i = lmax - lmin ) ;
END;
records:
BEGIN
nxt1 := fsp1↑.fstfld; nxt2 := fsp2↑.fstfld; comp := true;
WHILE (nxt1 <> NIL) AND (nxt2 <> NIL) DO
BEGIN
comp := comptypes(nxt1↑.idtype,nxt2↑.idtype) AND comp;
nxt1 := nxt1↑.next; nxt2 := nxt2↑.next
END;
comptypes := comp AND (nxt1 = NIL) AND (nxt2 = NIL)
AND (fsp1↑.recvar = NIL) AND (fsp2↑.recvar = NIL)
END;
(*IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
IF NO VARIANTS OCCUR*)
files:
comptypes := comptypes(fsp1↑.filtype,fsp2↑.filtype)
END (*CASE*)
ELSE (*FSP1↑.FORM <> FSP2↑.FORM*)
IF fsp1↑.form = subrange THEN comptypes := comptypes(fsp1↑.rangetype,fsp2)
ELSE
IF fsp2↑.form = subrange THEN comptypes := comptypes(fsp1,fsp2↑.rangetype)
ELSE
(* 25. ACCEPT PACKED ARRAYS OF CHAR AND CHAR AS SSTRINGS.*)
IF stringpack AND parsingparameters THEN
IF fsp1 = sstringptr THEN
comptypes := checksstring(fsp2)
ELSE
comptypes := false
ELSE
comptypes := false
ELSE comptypes := true
END (*COMPTYPES*) ;
PROCEDURE getbounds; (* (FSP: STP; VAR FMIN, FMAX: INTEGER) *)
(*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*)
BEGIN (*GETBOUNDS*)
fmin := 0; fmax := 0;
IF fsp <> NIL THEN
IF fsp = intptr THEN
BEGIN (* TYPE INTEGER = MININT..MAXINT *)
fmin := -maxint - 1;
fmax := maxint
END
ELSE
IF (fsp↑.form <= subrange) AND NOT comptypes(realptr,fsp) THEN
WITH fsp↑ DO
IF form = subrange THEN
BEGIN
fmin := vmin.ival;
fmax := vmax.ival
END
ELSE
IF fsp = asciiptr THEN
BEGIN (* TYPE ASCII = NUL..DEL *)
fmin := ord(nul);
fmax := ord(del)
END
ELSE
IF fconst <> NIL THEN fmax := fconst↑.values.ival
ELSE fmax := 0
END (*GETBOUNDS*) ;
FUNCTION string (* (FSP: STP) : BOOLEAN *) ; (* RETURNS TRUE IF FSP DESCRIBES A PACKED ARRAY OF CHAR *)
BEGIN (*STRING*)
string := false;
IF fsp <> NIL THEN
IF fsp↑.form = arrays THEN string := comptypes(fsp↑.aeltype,asciiptr)
END (*STRING*) ;
(* typedefinition (typE DEFINITION PARSER) *)
PROCEDURE typedefinition(fsys: setofsys; VAR fsp: stp; VAR fsize: addrrange;
VAR fbitsize: bitrange);
VAR
lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp;
lsize,displ: addrrange; i,lmin,lmax: integer;
packflag: boolean; lbitsize: bitrange;
lbtp: btp; bitcount:integer; bytes: bitrange;
FUNCTION log2(fval: integer): bitrange;
VAR
e: bitrange; h: integer;
BEGIN (*LOG2*)
e := 0; h := 1;
REPEAT
e := e + 1; h := h * 2
UNTIL fval <= h;
log2 := e
END (*LOG2*);
PROCEDURE simpletype(fsys: setofsys; VAR fsp: stp; VAR fsize: addrrange;
VAR fbitsize: bitrange);
VAR
lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange;
lcnt: integer; lvalu: valu; lbitsize: bitrange;
BEGIN (*SIMPLEtypE*)
fsize := 1;
skipiferr(simptypebegsys,208,fsys);
IF sy IN simptypebegsys THEN
BEGIN (* DECLARED SCALARS *)
IF sy = lparent THEN
BEGIN
ttop := top;
WHILE display[top].occur <> blck DO top := top - 1;
new(lsp,scalar,declared);
lcp1 := NIL; lcnt := 0;
REPEAT
insymbol;
IF sy = ident THEN
BEGIN
new(lcp,konst);
WITH lcp↑ DO
BEGIN
name := id; idtype := lsp; next := lcp1;
values.ival := lcnt
END;
enterid(lcp);
lcnt := lcnt + 1;
lcp1 := lcp; insymbol
END
ELSE error(209);
iferrskip(166,fsys + [comma,rparent])
UNTIL sy <> comma;
top := ttop;
WITH lsp↑ DO
BEGIN
selfstp := NIL; fconst := lcp1; size := 1; bitsize := log2(lcnt);
(*ADDITIONAL INFORMATION NEEDED TO STORE IDENTS OF DECLARED
SCALARS USED BY READ AND WRITE*)
vectorchain := 0; dimension := lcnt - 1; request := false;
nextscalar := declscalptr; declscalptr := lsp;
vectoraddr := 0; tlev := level
END;
IF sy = rparent THEN insymbol
ELSE error(152)
END (* SY = LPARENT *)
ELSE
BEGIN (* DEFINED CONSTANTS *)
IF sy = ident THEN
BEGIN
searchid([types,konst],lcp);
insymbol;
IF lcp↑.klass = konst THEN
BEGIN
new(lsp,subrange);
WITH lsp↑, lcp↑ DO
BEGIN
selfstp := NIL; rangetype := idtype;
IF string(rangetype) THEN
BEGIN
error(303); rangetype := NIL
END;
vmin := values; size := 1
END;
IF sy = colon THEN insymbol
ELSE error(151);
constant(fsys,lsp1,lvalu);
WITH lsp↑ DO
BEGIN
vmax := lvalu;
IF (vmin.ival < 0) OR (rangetype = realptr) THEN bitsize := bitmax
ELSE
IF vmax.ival = maxint THEN bitsize := bitmax
ELSE bitsize := log2(vmax.ival + 1);
IF NOT comptypes(rangetype,lsp1) THEN error(304)
END
END
ELSE
BEGIN
lsp := lcp↑.idtype;
IF lsp <> NIL THEN fsize := lsp↑.size
END
END (*SY = IDENT*)
ELSE (* SELF-DEFINING CONSTANTS *)
BEGIN
new(lsp,subrange);
constant(fsys + [colon],lsp1,lvalu);
IF string(lsp1) THEN
BEGIN
error(303); lsp1 := NIL
END;
WITH lsp↑ DO
BEGIN
rangetype := lsp1; vmin := lvalu; size := 1
END;
IF sy = colon THEN insymbol
ELSE error(151);
constant(fsys,lsp1,lvalu);
WITH lsp↑ DO
BEGIN
selfstp := NIL; vmax := lvalu;
IF (vmin.ival < 0) OR (rangetype = realptr) THEN bitsize := bitmax
ELSE
IF vmax.ival = maxint THEN bitsize := bitmax
ELSE bitsize := log2(vmax.ival + 1);
IF NOT comptypes(rangetype,lsp1) THEN error(304)
END
END;
IF lsp <> NIL THEN WITH lsp↑ DO
IF form = subrange THEN
IF rangetype <> NIL THEN
IF rangetype = realptr THEN
BEGIN
IF vmin.valp↑.rval > vmax.valp↑.rval THEN error(451)
END
ELSE
IF vmin.ival > vmax.ival THEN error(451)
END;
fsp := lsp;
IF lsp<>NIL THEN fbitsize := lsp↑.bitsize
ELSE fbitsize := 0;
iferrskip(166,fsys)
END
ELSE
BEGIN
fsp := NIL; fbitsize := 0
END
END (*SIMPLEtypE*) ;
PROCEDURE fieldlist(fsys: setofsys; VAR frecvar: stp; VAR ffirstfield: ctp);
LABEL
555;
VAR
lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4,tagsp: stp;
minsize,maxsize,lsize: addrrange; lvalu: valu;
lbitsize: bitrange;
lbtp: btp; minbitcount:integer;
lid : alfa ;
PROCEDURE recsection( VAR fcp: ctp; fsp: stp );
BEGIN (*RECSECTION*)
IF NOT packflag OR (lsize > 1) OR (lbitsize = 36) THEN
BEGIN
IF bitcount > 0 THEN
BEGIN
displ := displ + 1; bitcount := 0
END;
WITH fcp↑ DO
BEGIN
idtype := fsp; fldaddr := displ;
packf := notpack; fcp := next;
displ := displ + lsize
END
END
ELSE (*PACKED RECORDS*)
BEGIN
bitcount := bitcount + lbitsize;
IF bitcount>bitmax THEN
BEGIN
displ := displ + 1;
bitcount := lbitsize
END;
IF (lbitsize = 18) AND (bitcount IN [18,36]) THEN
BEGIN
WITH fcp↑ DO
BEGIN
idtype := fsp;
fldaddr := displ;
IF bitcount = 18 THEN packf := hwordl
ELSE packf := hwordr;
fcp := next
END
END
ELSE
WITH fcp↑, fldbyte DO
BEGIN
sbits := lbitsize;
pbits := bitmax - bitcount;
reladdr := displ;
dummybit := 0;
ibit := 0;
idtype := fsp;
packf := packk;
fcp := next
END
END
END (* RECSECTION *) ;
BEGIN (* FIELDLIST *)
nxt1 := NIL; lsp := NIL;
(* 13. ALLOW EXTRA SEMICOLONS AND NULL FIELDLISTS *)
WHILE sy = semicolon DO
insymbol;
skipiferr(fsys + [ident,casesy],452,fsys);
WHILE sy = ident DO
BEGIN
nxt := nxt1;
LOOP
IF sy = ident THEN
BEGIN
new(lcp,field);
WITH lcp↑ DO
BEGIN
name := id; idtype := NIL; next := nxt
END;
nxt := lcp;
enterid(lcp);
insymbol
END
ELSE error(209);
skipiferr([comma,colon],166,fsys + [semicolon,casesy])
EXIT IF sy <> comma ;
insymbol
END;
IF sy = colon THEN insymbol
ELSE error(151);
typedefinition(fsys + [casesy,semicolon],lsp,lsize,lbitsize);
IF lsp <> NIL THEN
IF lsp↑.form = files THEN error(254);
(*ASSIGN MEMORY SPACE FOR THE FIELDS IN THIS CYCLE*)
WHILE nxt <> nxt1 DO
recsection(nxt,lsp);
nxt1 := lcp;
(* 13. ALLOW NULL ENTRIES.*)
WHILE sy = semicolon DO
BEGIN
insymbol;
skipiferr(fsys + [ident,casesy,semicolon],452,fsys);
END;
END (*WHILE*);
nxt := NIL;
WHILE nxt1 <> NIL DO
WITH nxt1↑ DO
BEGIN
lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp
END;
ffirstfield := nxt;
IF sy = casesy THEN
BEGIN
lcp:=NIL; (*POSSIBILITY OF NO TAGFIELD IDENTIFIER*)
insymbol;
IF sy = ident THEN
BEGIN
lid := id ;
insymbol ;
IF (sy<>colon) AND (sy<>ofsy) THEN
BEGIN
error(151) ;
errandskip(160,fsys + [lparent])
END
ELSE
BEGIN
IF sy = colon THEN
BEGIN
new(lsp,tagfwithid);
new(lcp,field) ;
WITH lcp↑ DO
BEGIN
name := lid ; idtype := NIL ; next := NIL
END ;
enterid(lcp) ;
insymbol ;
IF sy <> ident THEN
BEGIN
errandskip(209,fsys + [lparent]) ; GOTO 555
END
ELSE
BEGIN
lid := id ;
insymbol ;
IF sy <> ofsy THEN
BEGIN
errandskip(160,fsys + [lparent]) ; GOTO 555
END
END
END
ELSE new(lsp,tagfwithoutid) ;
WITH lsp↑ DO
BEGIN
size:= 0 ; selfstp := NIL ;
fstvar := NIL;
IF form=tagfwithid THEN tagfieldp:=NIL
ELSE tagfieldtype := NIL
END;
frecvar := lsp;
id := lid ;
searchid([types],lcp1) ;
tagsp := lcp1↑.idtype;
IF tagsp <> NIL THEN
IF (tagsp↑.form <= subrange) OR string(tagsp) THEN
BEGIN
IF comptypes(realptr,tagsp) THEN error(210)
ELSE
IF string(tagsp) THEN error(169);
WITH lsp↑ DO
BEGIN
bitsize := tagsp↑.bitsize;
IF form = tagfwithid THEN tagfieldp := lcp
ELSE tagfieldtype := tagsp
END;
IF lcp <> NIL THEN
BEGIN
lbitsize :=tagsp↑.bitsize;
lsize := tagsp↑.size;
recsection(lcp,tagsp); (*RESERVES SPACE FOR THE TAGFIELD *)
IF bitcount > 0 THEN lsp↑.size := displ + 1
ELSE lsp↑.size := displ
END
END
ELSE error(402);
insymbol
END
END
ELSE errandskip(209,fsys + [lparent]) ;
555:
lsp1 := NIL; minsize := displ; maxsize := displ; minbitcount:=bitcount;
(* 13. ALLOW EXTRA SEMICOLONS.*)
WHILE sy = semicolon DO
insymbol;
LOOP
lsp2 := NIL;
LOOP
constant(fsys + [comma,colon,lparent],lsp3,lvalu);
IF NOT comptypes(tagsp,lsp3) THEN error(305);
new(lsp3,variant);
WITH lsp3↑ DO
BEGIN
nxtvar := lsp1; subvar := lsp2; varval := lvalu;
bitsize := lsp↑.bitsize; selfstp := NIL
END;
lsp1 := lsp3; lsp2 := lsp3
EXIT IF sy <> comma;
insymbol
END;
IF sy = colon THEN insymbol
ELSE error(151);
IF sy = lparent THEN insymbol
ELSE error(153);
fieldlist(fsys + [rparent,semicolon],lsp2,lcp);
IF bitcount > 0 THEN
BEGIN
displ := displ + 1 ; bitcount := 0
END ;
IF displ > maxsize THEN maxsize := displ;
WHILE lsp3 <> NIL DO
BEGIN
lsp4 := lsp3↑.subvar; lsp3↑.subvar := lsp2; lsp3↑.firstfield := lcp;
lsp3↑.size := displ ;
lsp3 := lsp4
END;
IF sy = rparent THEN
BEGIN
insymbol;
iferrskip(166,fsys + [semicolon])
END
ELSE error(152);
(* 13. ALLOW EXTRA SEMICOLONS.*)
WHILE sy = semicolon DO
insymbol;
EXIT IF sy IN fsys;
displ := minsize;
bitcount := minbitcount;
END;
displ := maxsize;
lsp↑.fstvar := lsp1
END (*IF SY = CASESY*)
ELSE
IF lsp <> NIL THEN
IF lsp↑.form = arrays THEN frecvar := lsp
ELSE frecvar := NIL
END (*FIELDLIST*) ;
BEGIN (*typedefinition*)
skipiferr(typebegsys,170,fsys);
IF sy IN typebegsys THEN
BEGIN
IF sy IN simptypebegsys THEN simpletype(fsys,fsp,fsize,fbitsize)
ELSE
IF sy = arrow THEN
BEGIN
new(lsp,pointer); fsp := lsp;
lbitsize := 18;
WITH lsp↑ DO
BEGIN
selfstp := NIL; eltype := NIL; size := 1; bitsize := lbitsize
END;
insymbol;
IF sy = ident THEN
BEGIN
search←error := false;
searchid([types],lcp);
search←error := true;
IF lcp = NIL THEN (*FORWARD REFERENCED typE ID*)
BEGIN
new(lcp,types);
WITH lcp↑ DO
BEGIN
name := id; idtype := lsp;
next := forward←pointer←type
END;
forward←pointer←type := lcp
END
ELSE
BEGIN
IF lcp↑.idtype <> NIL THEN
IF lcp↑.idtype↑.form = files THEN error(254)
ELSE lsp↑.eltype := lcp↑.idtype
END;
insymbol;
fbitsize:=18
END
ELSE error(209)
END
ELSE
BEGIN
IF sy = segmentsy THEN
BEGIN
error (169); (* 13.*)
insymbol;
skipiferr(typedels + [packedsy],170,fsys)
END;
IF sy = packedsy THEN
BEGIN
insymbol;
skipiferr(typedels,170,fsys);
packflag := true
END
ELSE packflag := false;
CASE sy OF
arraysy:
BEGIN
insymbol;
IF sy = lbrack THEN insymbol
ELSE error(154);
lsp1 := NIL;
LOOP
new(lsp,arrays);
WITH lsp↑ DO
BEGIN
aeltype := lsp1; inxtype := NIL; selfstp := NIL;
arraypf := packflag; size := 1
END;
lsp1 := lsp;
simpletype(fsys + [comma,rbrack,ofsy],lsp2,lsize,lbitsize);
IF lsp2 <> NIL THEN
IF lsp2↑.form <= subrange THEN
BEGIN
IF lsp2 = realptr THEN
BEGIN
error(210); lsp2 := NIL
END
ELSE
IF lsp2 = intptr THEN
BEGIN
error(306); lsp2 := NIL
END;
lsp↑.inxtype := lsp2
END
ELSE
BEGIN
error(403); lsp2 := NIL
END
EXIT IF sy <> comma;
insymbol
END;
IF sy = rbrack THEN insymbol
ELSE error(155);
IF sy = ofsy THEN insymbol
ELSE error(160);
typedefinition(fsys,lsp,lsize,lbitsize);
IF lsp <> NIL THEN
IF lsp↑.form = files THEN error(169) ;
REPEAT
WITH lsp1↑ DO
BEGIN
lsp2 := aeltype; aeltype := lsp;
IF inxtype <> NIL THEN
BEGIN
getbounds(inxtype,lmin,lmax);
i := lmax - lmin + 1;
IF arraypf AND (lbitsize<=18) THEN
BEGIN
bytes := bitmax DIV lbitsize;
WITH arraybps[lbitsize] DO
IF state = used THEN arraybpaddr := address
ELSE
BEGIN
new(lbtp);
WITH lbtp↑ DO
BEGIN
last := lastbtp; bitsize := lbitsize;
bytemax := bytes + 1 (*ONE MORE BYTEPOINTER USED FOR INCREMENT-OPERATIONS*) ;
arraysp := lsp1
END;
lastbtp := lbtp;
IF state = unused THEN
BEGIN
state := requested;
WITH abyte DO
BEGIN
sbits := lbitsize;
pbits := bitmax; dummybit := 0;
ibit := 0; ireg := reg1; reladdr := 0
END
END
END;
lsize := (i+bytes-1) DIV (bytes)
END
ELSE
BEGIN
lsize := lsize * i;
arraypf := false
END;
lbitsize := bitmax;
bitsize := lbitsize;
size := lsize
END
END;
lsp := lsp1; lsp1 := lsp2
UNTIL lsp1 = NIL
END;
recordsy:
BEGIN
insymbol;
oldtop := top;
IF top < displimit THEN
BEGIN
top := top + 1; display[top].fname := NIL ;
display[top].occur := crec ;
END
ELSE error(404);
displ := 0; bitcount := 0;
fieldlist(fsys-[semicolon] + [endsy],lsp1,lcp);
lbitsize := bitmax;
new(lsp,records);
WITH lsp↑ DO
BEGIN
selfstp := NIL;
fstfld := (*LCP;*) display[top].fname;
recvar := lsp1;
IF bitcount > 0 THEN size := displ + 1
ELSE size := displ;
bitsize := lbitsize; recordpf := packflag
END;
top := oldtop;
IF sy = endsy THEN insymbol
ELSE error(163)
END;
setsy:
BEGIN
insymbol;
IF sy = ofsy THEN insymbol
ELSE error(160);
simpletype(fsys,lsp1,lsize,lbitsize);
IF lsp1 <> NIL THEN
WITH lsp1↑ DO
CASE form OF
scalar:
IF scalkind = standard THEN error(268)
ELSE
IF fconst↑.values.ival > basemax THEN error(268);
subrange:
IF comptypes(rangetype,asciiptr) THEN
BEGIN
IF ((vmax.ival-offset) > basemax) OR ((vmin.ival-offset) < 0) THEN error(268)
END
ELSE
BEGIN
IF (rangetype = realptr) OR
((vmax.ival > basemax) OR (vmin.ival < 0)) THEN error(268)
END;
OTHERS:
BEGIN
error(461); lsp1 := NIL
END
END;
lbitsize := bitmax;
new(lsp,power);
WITH lsp↑ DO
BEGIN
selfstp := NIL; elset := lsp1; size:=2; bitsize := lbitsize
END
END;
filesy:
BEGIN
insymbol;
IF sy = ofsy THEN insymbol
ELSE error(160);
typedefinition(fsys,lsp1,lsize,lbitsize);
new(lsp,files);
lbitsize := bitmax;
WITH lsp↑ DO
BEGIN
selfstp := NIL;
filtype := lsp1; size := lsize+sizeoffileblock;
filepf := packflag; bitsize := lbitsize ;
(* REFER TO PROCEDURE "CODE←FOR←FILEBLOCKS"
IN "WRITE←MACHINE←CODE" *)
file←mode := binary←mode;
file←form := data←file;
IF comptypes(filtype,asciiptr) AND filepf THEN
BEGIN
file←mode := ascii←mode;
IF filtype <> NIL THEN
WITH filtype↑ DO
IF (form = subrange) AND
((vmin.ival >= ord(' ')) AND
(vmax.ival <= ord('←'))) THEN lsp↑.file←form := text←file
END;
IF filepf AND (file←mode = binary←mode) THEN filepf := false
END;
IF lsp1 <> NIL THEN
IF lsp1↑.form = files THEN
BEGIN
error(254); lsp↑.filtype := NIL
END
END
END (*CASE*);
fsp := lsp; fbitsize := lbitsize
END;
iferrskip(166,fsys)
END
ELSE fsp := NIL;
IF fsp = NIL THEN
BEGIN
fsize := 1;fbitsize := 0
END
ELSE fsize := fsp↑.size
END (*typedefinition*) ;
(* PARSING OF DECLARATIONS: labeldeclaration, constantdeclaration, typedeclaration, variabledeclaration *)
PROCEDURE labeldeclaration;
VAR
lcp: ctp;
BEGIN (*LABELDECLARATION*)
IF jumper < jump←max THEN jumper := jumper + 1
ELSE error(319);
current←jump := jumper;
jump←table[jumper] := 0;
LOOP
IF sy = intconst THEN
BEGIN
new(lcp,labels);
WITH lcp↑ DO
BEGIN
scope := level; name := id; idtype := NIL; next := last←label;
goto←chain := 0; label←address := 0; last←label := lcp;
jump←index := jumper; exit←jump := false;
IF val.ival > labmax THEN error(265)
END;
enterid(lcp);
insymbol
END
ELSE error(255);
iferrskip(166,fsys + [comma,semicolon])
EXIT IF sy <> comma;
insymbol
END;
IF sy = semicolon THEN insymbol
ELSE error(156)
END (*LABELDECLARATION*) ;
PROCEDURE constantdeclaration;
VAR
lcp: ctp; lsp: stp; lvalu: valu;
BEGIN (*CONSTANTDECLARATION*)
skipiferr([ident],209,fsys);
WHILE sy = ident DO
BEGIN
new(lcp,konst);
WITH lcp↑ DO
BEGIN
name := id; idtype := NIL; next := NIL
END;
insymbol;
IF (sy = relop) AND (op = eqop) THEN insymbol
ELSE error(157);
constant(fsys + [semicolon],lsp,lvalu);
enterid(lcp);
lcp↑.idtype := lsp; lcp↑.values := lvalu;
IF sy = semicolon THEN
BEGIN
insymbol;
iferrskip(166,fsys + [ident])
END
ELSE error(156)
END
END (*CONSTANTDECLARATION*) ;
PROCEDURE typedeclaration;
VAR
lcp,lcp1,lcp2: ctp; lsp: stp; lsize: addrrange;
lbitsize: bitrange;
BEGIN (*CONSTANTDECLARATION*)
skipiferr([ident],209,fsys);
WHILE sy = ident DO
BEGIN
new(lcp,types);
WITH lcp↑ DO
BEGIN
name := id; next := NIL
END;
insymbol;
IF (sy = relop) AND (op = eqop) THEN insymbol
ELSE error(157);
typedefinition(fsys + [semicolon],lsp,lsize,lbitsize);
enterid(lcp);
WITH lcp↑ DO
BEGIN
idtype := lsp;
(* LOOK FOR UNSATISFIED POINTER FORWARD REFERENCES;
THERE MAY BE MORE THAN ONE FOR ONE typE-DECLARATION *)
lcp1 := forward←pointer←type;
WHILE lcp1 <> NIL DO
BEGIN
IF lcp1↑.name = name THEN
BEGIN
IF idtype↑.form = files THEN
BEGIN
error(254);
lcp1↑.idtype↑.eltype := NIL
END
ELSE lcp1↑.idtype↑.eltype := idtype;
IF lcp1 <> forward←pointer←type THEN lcp2↑.next := lcp1↑.next
ELSE forward←pointer←type := lcp1↑.next
END
ELSE lcp2 := lcp1;
lcp1 := lcp1↑.next
END
END;
IF sy = semicolon THEN
BEGIN
insymbol;
iferrskip(166,fsys + [ident])
END
ELSE error(156)
END;
WHILE forward←pointer←type <> NIL DO
BEGIN
error←with←text(405,forward←pointer←type↑.name);
forward←pointer←type := forward←pointer←type↑.next
END
END (*TYPEDECLARATION*) ;
PROCEDURE variabledeclaration;
VAR
lcp,nxt: ctp; lsp: stp; lsize: addrrange;
lbitsize: bitrange; lparmptr: ptp; found: boolean;
lfileptr: ftp;
BEGIN (*VARIABLEDECLARATION*)
nxt := NIL;
REPEAT
LOOP
IF sy = ident THEN
BEGIN
new(lcp,vars);
WITH lcp↑ DO
BEGIN
name := id; next := nxt;
idtype := NIL; vkind := actual; vlev := level
END;
enterid(lcp);
nxt := lcp;
insymbol
END
ELSE error(209);
skipiferr(fsys + [comma,colon] + typedels,166,[semicolon])
EXIT IF sy <> comma;
insymbol
END;
IF sy = colon THEN insymbol
ELSE error(151);
typedefinition(fsys + [semicolon] + typedels,lsp,lsize,lbitsize);
IF NOT testpacked AND (lsp <> NIL) THEN
BEGIN
IF lsp↑.form = arrays THEN testpacked := lsp↑.arraypf;
IF lsp↑.form = records THEN testpacked := lsp↑.recordpf
END;
WHILE nxt <> NIL DO
WITH nxt↑ DO
BEGIN
idtype := lsp;
%24 (* 20.*)
IF idtype↑.form = files THEN
BEGIN
vaddr := filelc;
filelc := filelc + lsize;
IF filelc > maxfilecode THEN
error (557);
END
ELSE
BEGIN
(* 20.*) \
vaddr := lc;
lc := lc + lsize ;
%24 END;
(* 20.*) \
IF lsp <> NIL THEN
IF lsp↑.form = files THEN
IF level > 1 THEN error(454)
ELSE
BEGIN
IF start←channel = 0 THEN channel := fileptr↑.fileident↑.channel
ELSE
BEGIN
channel := start←channel;
start←channel := 0
END;
IF channel < max←channel THEN channel := channel + 1
ELSE error(354);
new(lfileptr);
WITH lfileptr↑ DO
BEGIN
nextftp := fileptr ;
fileident := nxt
END ;
fileptr := lfileptr;
lparmptr := parmptr; found := false;
WHILE lparmptr <> NIL DO
WITH lparmptr↑ DO
BEGIN
IF fileid = name THEN
IF found THEN error(466)
ELSE
BEGIN
fileidptr := nxt; found := true
END;
lparmptr := nextptp
END
END (*ELSE*) ;
nxt := next
END;
IF sy = semicolon THEN
BEGIN
insymbol;
iferrskip(166,fsys + [ident])
END
ELSE error(156)
UNTIL NOT (sy IN typedels + [ident]);
WHILE forward←pointer←type <> NIL DO
BEGIN
error←with←text(405,forward←pointer←type↑.name);
forward←pointer←type := forward←pointer←type↑.next
END
END (*VARIABLEDECLARATION*) ;
PROCEDURE proceduredeclaration(procflag: boolean);
VAR
oldlev: 0..maxlevel; lcp,lcp1: ctp; lsp: stp;
forw: boolean; oldtop: disprange; lnxt: ctp;
oldcurrname: alfa; (* 27.*)
llc : addrrange;
lsys: setofsys;
PROCEDURE parameterlist(fsys:setofsys; VAR fip : ctp);
VAR
lip,lip1,lip2,lip3,lip4 : ctp; lsp : stp;
lkind : idkind; lpars:addrrange; funcdecl : boolean;
PROCEDURE ffparlist ( fsys : setofsys; VAR fip : ctp; VAR fparlc : addrrange);
VAR
lip,lip1,lip2,lip3 : ctp; lsp : stp;
lkind : idkind; lpars : addrrange; funcdecl : boolean;
BEGIN (*FFPARLIST*)
fip:=NIL;
skipiferr(fsys+[lparent],256,[]);
IF sy=lparent THEN
BEGIN
insymbol;
skipiferr([ident,varsy,proceduresy,functionsy],256,fsys+[rparent]);
IF sy IN [ident ,varsy,proceduresy,functionsy] THEN
LOOP
IF sy IN [proceduresy, functionsy] THEN
BEGIN
funcdecl:= sy=functionsy;
insymbol;
IF funcdecl THEN new(lip,func,declared,formal)
ELSE
new(lip,proc,declared,formal);
WITH lip↑ DO
BEGIN
idtype:=NIL; next:=NIL; pflev:=level;
pfaddr:=fparlc; fparlc:=fparlc+1;
lpars:=1+ord(funcdecl);
IF funcdecl THEN ffparlist(fsys+[rparent,colon,semicolon],lip3,lpars)
ELSE
ffparlist(fsys+[rparent,semicolon],lip3,lpars);
fparam:=lip3; parlistsize:=lpars;
END;
IF funcdecl THEN
IF sy=colon THEN
BEGIN
insymbol;
IF sy<>ident THEN error(209)
ELSE
BEGIN
searchid([types],lip2);
lsp:=lip2↑.idtype;
IF lsp<> NIL THEN
IF NOT(lsp↑.form IN [scalar,subrange,pointer]) THEN
BEGIN
error(551);
lsp:=NIL
END;
lip↑.idtype:=lsp
END
END
ELSE error(151)
END (*SY IN [FUNCTIONSY,PROCEDURESY]*)
ELSE
BEGIN
IF sy=varsy THEN
BEGIN
insymbol;
lkind:=formal;
IF sy=colon THEN insymbol
ELSE error(151)
END
ELSE lkind:=actual;
IF sy=ident THEN
BEGIN
searchid([types],lip2);
insymbol;
lsp:=lip2↑.idtype;
IF lsp<>NIL THEN
IF lkind=actual THEN
IF lsp↑.form=files THEN
BEGIN
error(355); lsp:=NIL
END;
new(lip,vars);
WITH lip↑ DO
BEGIN
idtype:=lsp; next:=NIL; vkind:=lkind; vlev:=level;
vaddr:=fparlc;
IF lkind=formal THEN fparlc:=fparlc+1
ELSE
IF lsp<>NIL THEN fparlc:=fparlc+lsp↑.size;
END
END
ELSE
BEGIN
error(209); lip:=NIL
END
END;
IF lip<>NIL THEN
BEGIN
IF fip=NIL THEN fip:=lip
ELSE lip1↑.next:=lip;
lip1:=lip
END;
skipiferr([semicolon,ident,varsy,proceduresy,functionsy,rparent],256,fsys);
EXIT IF NOT(sy IN [semicolon,ident,varsy,proceduresy,functionsy]);
IF sy=semicolon THEN insymbol
ELSE error(156)
END (*LOOP*);
IF sy=rparent THEN insymbol
ELSE error(152);
skipiferr(fsys,166,[])
END
END (*FFPARLIST*);
BEGIN (*PARAMETERLIST*)
fip:=NIL; lip1:=NIL; lsp := NIL;
skipiferr(fsys+[lparent],256,[]);
IF sy=lparent THEN
BEGIN
IF forw THEN error(553);
insymbol;
skipiferr([proceduresy,functionsy,varsy,ident],256,fsys+[rparent]);
IF sy IN [proceduresy,functionsy,varsy,ident] THEN
LOOP
lip2:=NIL;
IF sy IN [proceduresy,functionsy] THEN
BEGIN
funcdecl:= sy=functionsy;
insymbol;
LOOP
IF sy=ident THEN
BEGIN
IF funcdecl THEN
new(lip,func,declared,formal)
ELSE
new(lip,proc,declared,formal);
WITH lip↑ DO
BEGIN
name:=id; next:=NIL; pflev:=level;idtype:=NIL;
pfaddr:=lc; lc:=lc+1; highest←register:=parregcmax
END;
enterid(lip);
insymbol;
IF fip=NIL THEN fip:=lip
ELSE lip1↑.next:=lip;
lip1:=lip;
IF lip2=NIL THEN lip2:=lip;
END
ELSE errandskip(209,fsys+[lparent,colon,comma,ident,semicolon,rparent]);
EXIT IF NOT (sy IN [comma,ident]);
IF sy=comma THEN insymbol
ELSE error(158)
END (*LOOP*);
IF funcdecl THEN
BEGIN
lpars:=2;
ffparlist(fsys+[colon,semicolon,rparent],lip3,lpars);
lsp:=NIL;
IF sy=colon THEN
BEGIN
insymbol;
IF sy=ident THEN
BEGIN
searchid([types],lip4);
lsp:=lip4↑.idtype;
IF lsp<>NIL THEN
IF NOT(lsp↑.form IN [scalar,subrange,pointer]) THEN
BEGIN
error(551); lsp:=NIL
END;
insymbol
END
ELSE errandskip(209,fsys+[colon,comma,ident])
END
ELSE error(151);
WHILE lip2<>NIL DO WITH lip2↑ DO
BEGIN
idtype:=lsp;
fparam:=lip3; parlistsize:=lpars;
lip2:=next
END
END
ELSE
BEGIN
lpars:=1;
ffparlist(fsys+[semicolon,rparent],lip3,lpars);
WHILE lip2<>NIL DO WITH lip2↑ DO
BEGIN
fparam:=lip3;
parlistsize:=lpars;
lip2:=next
END
END
END (*SY IN [PROCEDURESY,FUNCTIONSY]*)
ELSE
BEGIN
IF sy=varsy THEN
BEGIN
lkind:=formal; insymbol
END
ELSE lkind:=actual;
LOOP
IF sy=ident THEN
BEGIN
new(lip,vars);
WITH lip↑ DO
BEGIN
name:=id; next:=NIL; vkind:=lkind; vlev:=level;
END;
enterid(lip);
insymbol;
IF fip=NIL THEN fip:=lip
ELSE lip1↑.next:=lip;
lip1:=lip;
IF lip2=NIL THEN lip2:=lip
END
ELSE errandskip(209,fsys+[colon,comma,ident]);
EXIT IF NOT(sy IN [comma,ident]);
IF sy=comma THEN insymbol
ELSE error(158)
END (*LOOP*);
IF sy=colon THEN
BEGIN
insymbol;
IF sy=ident THEN
BEGIN
searchid([types],lip3);
insymbol;
lsp:=lip3↑.idtype;
IF lsp<>NIL THEN
IF (lkind=actual) AND(lsp↑.form=files) THEN
BEGIN
error(355); lsp:=NIL
END
END
ELSE
error(209)
END
ELSE error(151);
WHILE lip2<>NIL DO WITH lip2↑ DO
BEGIN
vaddr:=lc;
IF lsp<>NIL THEN
IF vkind=formal THEN lc:=lc+1
ELSE lc:=lc+lsp↑.size;
idtype:=lsp;
lip2:=next
END;
END (*SY<>FUNCTIONSY*);
skipiferr([rparent,semicolon],256,[proceduresy,functionsy,ident,varsy]+fsys)
EXIT IF NOT(sy IN [semicolon,proceduresy,functionsy,varsy,ident]);
IF sy=semicolon THEN insymbol
ELSE error(156)
END (*LOOP*);
IF sy=rparent THEN insymbol
ELSE error(152);
skipiferr(fsys,166,[])
END (*SY=LPARENT*)
END (*PARAMETERLIST*);
BEGIN (*PROCEDUREDECLARATION*)
IF genprocfile THEN (* 27.*)
headline := linecnt;
oldcurrname := currname;
fsys:=fsys-[initprocsy];
llc := lc;
IF procflag THEN lc := 1
ELSE lc := 2;
IF sy = ident THEN
BEGIN
currname := id; (* 27.*)
searchsection(display[top].fname,lcp); (*DECIDE WHETHER DECLARED FORWARD*)
IF lcp <> NIL THEN (* IT SHOULD BE FORWARD *)
WITH lcp↑ DO
BEGIN
IF klass = proc THEN
IF pfkind=actual THEN forw:=forwdecl AND procflag
ELSE forw:=false
ELSE
IF klass = func THEN
IF pfkind=actual THEN forw:=forwdecl AND NOT procflag
ELSE forw:=false
ELSE forw := false;
IF NOT forw THEN error(558)
END
ELSE forw := false;
IF NOT forw THEN
BEGIN
IF procflag THEN new(lcp,proc,declared,actual)
ELSE new(lcp,func,declared,actual);
WITH lcp↑ DO
BEGIN
name := id; idtype := NIL; testfwdptr := NIL; highest←register := parregcmax;
forwdecl := false; externdecl := false; language := pascalsy; parlistsize:=0;
pflev := level; pfaddr := 0; FOR i := 0 TO maxlevel DO linkchain[i] := 0
END;
enterid(lcp)
END
ELSE lc:=lcp↑.parlistsize;
insymbol
END
ELSE (* SY <> IDENT *)
BEGIN
error(209);
IF procflag THEN lcp := uprcptr
ELSE lcp := ufctptr
END;
oldlev := level; oldtop := top;
IF level < maxlevel THEN level := level + 1
ELSE error(453);
IF top < displimit THEN
BEGIN
top := top + 1;
WITH display[top] DO
BEGIN
fname := NIL; occur := blck;
IF debug THEN
BEGIN
new(lcp1); lcp1↑ := uprcptr↑;
lcp1↑.next := lcp;
enterid(lcp1);
IF forw AND (lcp↑.next <> NIL) THEN
BEGIN
lcp1↑.llink := lcp↑.next; lcp1↑.rlink := lcp↑.next;
lcp↑.next↑.selfctp := NIL
END
END
ELSE (* NOT DEBUG *)
IF forw THEN fname := lcp↑.next
END (*WITH DISPLAY[TOP]*)
END
ELSE (* TOP >= DISPLIMIT *)
error(404);
IF procflag THEN
BEGIN
parameterlist([semicolon],lcp1);
IF NOT forw THEN WITH lcp↑ DO
BEGIN
next:=lcp1; parlistsize:=lc
END
END
ELSE (* NOT PROCFLAG *)
BEGIN
parameterlist([semicolon,colon],lcp1);
IF NOT forw THEN WITH lcp↑ DO
BEGIN
next := lcp1; parlistsize:=lc
END;
IF sy = colon THEN
BEGIN
insymbol;
IF sy = ident THEN
BEGIN
IF forw THEN error(552);
searchid([types],lcp1);
lsp := lcp1↑.idtype;
lcp↑.idtype := lsp;
IF lsp <> NIL THEN
IF NOT (lsp↑.form IN [scalar,subrange,pointer]) THEN
BEGIN
error(551); lcp↑.idtype := NIL
END;
insymbol
END
ELSE errandskip(209,fsys + [semicolon])
END
ELSE
IF NOT forw THEN error(455)
END;
IF sy = semicolon THEN insymbol
ELSE error(156);
IF sy = forwardsy THEN
BEGIN
IF forw THEN error(257)
ELSE
WITH lcp↑ DO
BEGIN
testfwdptr := forward←procedures; forward←procedures := lcp; forwdecl := true;
IF next <> NIL THEN next↑.selfctp := uvarptr
END;
insymbol;
IF sy = semicolon THEN insymbol
ELSE error(156);
iferrskip(166,fsys)
END (* SY = FORWARDSY *)
ELSE (* SY <> FORWARDSY *)
WITH lcp↑ DO
BEGIN
IF sy IN (languagesys + [externsy]) THEN
BEGIN
%24 error(169); (*17.*) \
IF forw THEN error(257)
ELSE externdecl := true;
%13
IF NOT external THEN
begin \
ttyread := ttyread or resettty;
outputwrite := openoutput or outputwrite; (* 13. OPEN OUTPUT ONLY IF NEEDED.*)
%13 (* 17.*) end; \
IF level <> 2 THEN error(464);
IF sy IN languagesys THEN language := sy;
insymbol;
%13 (* 17.*)
IF (library←index = 0) OR (NOT library[language].chained) THEN
BEGIN
library←index:= library←index+1;
library←order[library←index]:= language;
library[language].chained:= true
END;
(* 17.*) \
pflev := 1; pfchain := externpfptr; externpfptr := lcp;
IF sy = semicolon THEN insymbol
ELSE error(156);
iferrskip(166,fsys)
END (* SY = EXTERNSY *)
ELSE (* (SY <> EXTERNSY) AND (SY <> FORWARDSY) *)
BEGIN
pfchain := localpfptr;
localpfptr := lcp;
forwdecl := false;
activated := true;
block(lcp,fsys,[beginsy,functionsy,proceduresy,period,semicolon]);
activated := false;
IF sy = semicolon THEN
BEGIN
lsys := [proceduresy,functionsy,beginsy];
%24 if initglobals then
begin
lsys := lsys + [initprocsy];
dp := true;
end; \
insymbol;
%24 dp := false; \
skipiferr(lsys,166,fsys)
END
ELSE error(156)
END (* SY <> EXTERNSY *)
END (* SY <> FORWARDSY *) ;
level := oldlev; top := oldtop; lc := llc;
currname := oldcurrname; (* 27.*)
END (*PROCEDUREDECLARATION*) ;
(* BODY[generate←word,insert←address,increment←regc,deposit←constant,macro..,put←pagenumber,put←linenumber,support,alfaconstant*)
PROCEDURE body(fsys: setofsys);
CONST
(* FILOPN = 3B; FILBTH = 20B; (* NOT USED.*)
fileof = 1B; fileol = 2B; filsta = 11B; fildev = 12B;
filbhp = 13B; filnam = 14B; fillnr = 23B; filcmp = 25B;
VAR
last←file: ctp;
reg2←saved: boolean;
reg2←location: addrrange;
PROCEDURE generate←word(frelbyte: relbyte; flefth: addrrange; frighth: addrrange);
BEGIN (*GENERATE←WORD*)
cix := cix + 1;
IF cix > code←size THEN
BEGIN
IF NOT overrun THEN
BEGIN
overrun := true;
IF fprocp = NIL THEN error←with←text(356,'MAIN ')
ELSE error←with←text(356,fprocp↑.name)
END;
cix := 0
END;
WITH code←array↑.halfword[cix] DO
BEGIN
lefthalf := flefth;
righthalf := frighth
END;
code←reference↑[cix] := noinstr; code←relocation↑[cix] := frelbyte;
ic := ic + 1
END (*GENERATE←WORD*) ;
PROCEDURE insert←address(frelbyte: relbyte; fcix:coderange; fic:addrrange);
BEGIN (*INSERT←ADDRESS*)
code←array↑.instruction[fcix].address := fic;
code←relocation↑[fcix] := frelbyte
END (*INSERT←ADDRESS*);
PROCEDURE increment←regc;
BEGIN (*INCREMENT←REGC*)
regc := regc + 1 ;
IF regc > regcmax THEN
BEGIN
error(310) ; regc := regin
END
END (*INCREMENT←REGC*);
PROCEDURE deposit←constant(konsttyp:cstclass; fattr:attr);
VAR
ii:integer;
lksp,llksp: ksp;
lcsp: csp;
lref: coderefs;
newconstant,existant:boolean;
lcix: coderange;
BEGIN (*DEPOSIT←CONSTANT*)
newconstant:=true; lksp := firstkonst; (* CHECK WHETEHER THE CONSTANT EXISTS ALREADY *)
WHILE (lksp <> NIL) AND newconstant DO
WITH lksp↑,constptr↑ DO
BEGIN
IF cclass = konsttyp THEN
CASE konsttyp OF
reel:
newconstant := rval <> fattr.cval.valp↑.rval;
int:
newconstant := intval <> fattr.cval.ival;
pset:
newconstant := pval <> fattr.cval.valp↑.pval;
bptr:
newconstant := byte <> fattr.cval.byte;
strd,
strg:
IF fattr.cval.valp↑.slgth = slgth THEN
BEGIN
existant := true;
ii := 1;
REPEAT
IF fattr.cval.valp↑.sval[ii] <> sval[ii] THEN existant := false;
ii:=ii+1
UNTIL (ii>slgth) OR NOT existant;
IF existant THEN newconstant := false
END
END (*CASE*);
llksp := lksp; lksp := nextkonst
END (*WHILE*);
IF konsttyp = bptr THEN lref := pointref
ELSE lref := constref;
IF NOT newconstant (* IF IT DOES NOT EXIST YET, CREATE IT *) THEN
WITH llksp↑ DO
BEGIN
insert←address(right,cix,addr); code←reference↑[cix]:= lref;
IF konsttyp IN [pset,strd] THEN
BEGIN
insert←address(right,cix-1,addr-1); code←reference↑[cix-1]:= lref
END;
addr:= ic-1
END
ELSE
BEGIN
IF konsttyp = int THEN
BEGIN
new(lcsp,int); lcsp↑.intval := fattr.cval.ival
END
ELSE
IF konsttyp = bptr THEN
BEGIN
new(lcsp,bptr); lcsp↑.byte := fattr.cval.byte
END
ELSE lcsp := fattr.cval.valp;
code←reference↑[cix] := lref;
IF konsttyp IN [pset,strd] THEN code←reference↑[cix-1] := lref;
new(lksp);
WITH lksp↑ DO
BEGIN
addr := ic-1; double←chain := konsttyp IN [pset,strd];
constptr := lcsp; nextkonst := NIL
END;
IF firstkonst = NIL THEN firstkonst := lksp
ELSE llksp↑.nextkonst := lksp
END
END (*DEPOSIT←CONSTANT*);
PROCEDURE macro(frelbyte : relbyte;
finstr : instrange;
fac : acrange;
findbit : ibrange;
finxreg : acrange;
faddress : addrrange);
BEGIN (*MACRO*)
%13
IF NOT initglobals THEN (* 24.*) \
BEGIN
cix := cix + 1;
IF cix > code←size THEN
BEGIN
IF NOT overrun THEN
BEGIN
overrun := true;
IF fprocp = NIL THEN error←with←text(356,'MAIN ')
ELSE error←with←text(356, fprocp↑.name)
END;
cix := 0
END;
WITH code←array↑.instruction[cix] DO
BEGIN
instr :=finstr;
ac :=fac;
indbit :=findbit;
inxreg :=finxreg;
address :=faddress;
code←reference↑[cix]:= noref; code←relocation↑[cix] := frelbyte
END;
ic := ic + 1
END
%13
ELSE error(507) (* 24.*) \
END (*MACRO*);
PROCEDURE macro5(frelbyte: relbyte; finstr : instrange; fac,finxreg : acrange; faddress : addrrange);
BEGIN
macro(frelbyte,finstr,fac,0,finxreg,faddress)
END;
PROCEDURE macro4(finstr: instrange;fac, finxreg: acrange;faddress: addrrange);
BEGIN
macro(no,finstr,fac,0,finxreg,faddress)
END;
PROCEDURE macro3(finstr : instrange; fac:acrange; faddress: addrrange);
BEGIN
macro(no,finstr,fac,0,0,faddress)
END;
PROCEDURE macro4r(finstr : instrange; fac,finxreg : acrange; faddress : addrrange);
BEGIN
macro(right,finstr,fac,0,finxreg,faddress)
END;
PROCEDURE macro3r(finstr : instrange; fac:acrange; faddress: addrrange);
BEGIN
macro(right,finstr,fac,0,0,faddress)
END;
PROCEDURE macro2(finstr: instrange; fac: acrange);
BEGIN
macro(no,finstr,fac,0,0,0)
END;
PROCEDURE put←pagenumber;
VAR
lrelbyte: relbyte;
BEGIN (*PUT←PAGENUMBER*)
lrelbyte := right;
WITH pager DO
BEGIN
lastpager := ic;
WITH word1 DO
BEGIN
IF (address = 0) OR (address = 377777B) THEN lrelbyte := no;
macro5(lrelbyte,304B(*CAIA*),ac,inxreg,address)
END;
IF (rhalf = 0) OR (rhalf = 377777B) THEN generate←word(no,lhalf,rhalf)
ELSE generate←word(right,lhalf,rhalf);
lastpage := pagecnt
END
END (*PUT←PAGENUMBER*);
PROCEDURE put←linenumber;
VAR
lrelbyte: relbyte;
BEGIN (*PUT←LINENUMBER*)
lrelbyte := right;
IF pagecnt <> lastpage THEN put←pagenumber;
IF linecnt <> lastline THEN (*BREAKPOINT*)
BEGIN
IF hassoslines THEN
BEGIN
linecnt := 0;
FOR i := 1 TO 5 DO linecnt := 10*linecnt + ord(linenr[i]) - ord('0')
END;
linediff := linecnt - lastline;
IF (laststop = 0) OR (laststop = 377777B) THEN lrelbyte := no;
IF linediff > 255 THEN
BEGIN
macro5(lrelbyte,334B(*SKIPA*),0,0,laststop);
laststop := ic-1;
macro3(320B(*JUMP*),0,lastline)
END
ELSE
BEGIN
macro5(lrelbyte,320B(*JUMP*),linediff MOD 16,linediff DIV 16,laststop); (*NOOP*)
laststop := ic - 1
END;
lastline := linecnt
END
END (*PUT←LINENUMBER*);
PROCEDURE support(fsupport: supports);
BEGIN (*SUPPORT*)
IF fsupport = fortranreset THEN macro3r(265B(*JSP*),basis,runtime←support.link[fortranreset])
ELSE
IF fsupport = exitprogram THEN macro3r(254B(*JRST*),0,runtime←support.link[exitprogram])
ELSE macro3r(260B(*PUSHJ*),topp,runtime←support.link[fsupport]);
code←reference↑[cix]:= externref;
%13 runtime←support.link[fsupport]:= ic-1 (* 19.*) \
END (*SUPPORT*);
PROCEDURE alfaconstant( fstring: alfa);
VAR
lcsp: csp;
BEGIN (*ALFACONSTANT*)
new(lcsp,strg);
WITH lcsp↑ DO
BEGIN
slgth := 10; FOR i := 1 TO 10 DO sval[i] := fstring[i]
END;
WITH gattr DO
BEGIN
typtr := alfaptr;
kind := cst; cval.valp := lcsp
END
END (*ALFACONSTANT*);
(*closefiles, enterbody, leavebody*)
PROCEDURE close←files;
VAR
lfileptr: ftp;
BEGIN (*CLOSE←FILES*)
lfileptr := fileptr;
WHILE lfileptr <> NIL DO
WITH lfileptr↑, fileident↑ DO
BEGIN
%24
IF name <> 'TTYOUTPUT ' THEN
BEGIN (* 21.*) \
macro3r(551B(*HRRZI*),regin+1,vaddr);
support(closefile);
%24 END;
(* 21.*) \
lfileptr := nextftp
END;
%24 (* 21. CALL TO TIMEREPORT.*)
macro3r(551B(*HRRZI*),regin+1,stdfileptr[4]↑.vaddr);
alfaconstant(programname);
gattr.cval.valp↑.cclass := strd;
macro2(200B(*MOVE*),regin+3);
macro2(200B(*MOVE*),regin+2);
deposit←constant (strd,gattr);
support(showruntime);
(* 21.*) \
END (*CLOSE←FILES*);
PROCEDURE enterbody;
VAR
i: integer; lcp : ctp;
lbtp: btp;
BEGIN (*ENTERBODY*)
lbtp := lastbtp;
WHILE lbtp <> NIL DO
BEGIN
WITH lbtp↑, arraybps[bitsize] DO
IF state = requested THEN
BEGIN
arraysp↑.arraybpaddr := ic;
address := ic; state := calculated;
ic := ic + bytemax
END
ELSE arraysp↑.arraybpaddr := address;
lbtp := lbtp↑.last
END;
IF fprocp <> NIL THEN
BEGIN
generate←word(no,0,377777B); idtree := cix; (*IF DEBUG, INSERT TREE POINTER HERE*)
WITH fprocp↑ DO
IF pflev > 1 THEN FOR i := maxlevel DOWNTO pflev+1 DO
macro4(540B(*HRR*),basis,basis,-1);
pfstart := ic;
IF fprocp↑.pflev = 1 THEN macro4(512B(*HLLZM*),basis,topp,-1)
ELSE macro4(202B(*MOVEM*),basis,topp,-1);
macro3(507B(*HRLS*),basis,topp);
macro4(307B(*CAIG*),newreg,topp,0); stacksize1 := cix;
support(stackoverflow);
macro4(541B(*HRRI*),topp,topp,0); stacksize2 := cix;
IF testpacked THEN
IF lc-lcpar <= 4 THEN FOR i := lcpar TO lc-1 DO macro4(402B(*SETZM*),0,basis,i)
ELSE
BEGIN
macro4(551B(*HRRZI*),reg1,basis,lcpar);
macro3(505B(*HRLI*),reg1,lcpar-lc);
macro4(402B(*SETZM*),0,reg1,0);
macro3r(253B(*AOBJN*),reg1,ic-1)
END;
regc := regin+1;
lcp := fprocp↑.next;
WHILE lcp <> NIL DO
WITH lcp↑ DO
BEGIN
IF klass <> vars THEN
BEGIN
IF regc <= fprocp↑.highest←register THEN
BEGIN
macro4(202B(*MOVEM*),regc,basis,pfaddr);
increment←regc
END
END
ELSE
IF idtype <> NIL THEN
IF (vkind=formal) OR (idtype↑.size=1) THEN (*COPY PARAMETERS FROM REGISTERS INTO LOCAL CELLS*)
BEGIN
IF regc <= fprocp↑.highest←register THEN
BEGIN
macro4(202B(*MOVEM*),regc,basis,vaddr); regc := regc + 1
END
END
ELSE
IF idtype↑.size=2 THEN
BEGIN
IF regc <= fprocp↑.highest←register THEN
BEGIN
macro4(202B(*MOVEM*),regc,basis,vaddr);
IF regc<fprocp↑.highest←register THEN macro4(202B(*MOVEM*),regc+1,basis,vaddr+1)
END;
regc:=regc+2
END
ELSE
BEGIN
IF regc <= fprocp↑.highest←register THEN (*COPY MULTIPLE VALUES INTO LOCAL CELLS*)
BEGIN
macro3(514B(*HRLZ*),reg1,regc); regc := regc + 1
END
ELSE macro4(514B(*HRLZ*),reg1,basis,vaddr);
macro4(541B(*HRRI*),reg1,basis,vaddr);
macro4(251B(*BLT*),reg1,basis,vaddr+idtype↑.size-1)
END;
lcp := lcp↑.next
END
END
ELSE (* FPROCP = NIL *)
main←start := ic;
IF (current←jump <> 0) %13 AND (NOT external OR (level > 1)) \ (* 14.*) THEN
BEGIN
jump←table[current←jump] := ic;
macro2(202B(*MOVEM*),basis); code←reference↑[cix] := saveref;
macro2(202B(*MOVEM*),topp); code←reference↑[cix] := saveref
END
END (*ENTERBODY*);
PROCEDURE leavebody;
VAR
lcp: ctp; i: integer;
lksp: ksp ; lparmptr: ptp;
ldeclscalptr: stp;
icchange: PACKED RECORD
CASE boolean OF
false:(icval: addrrange);
true :(iccsp: csp)
END;
%13 (* 28.*)
lpcross←file,lpcross←device: alfa;
(* 28.*) \
%24 laddress: addrrange;
counttop,index: 1..101;
lcntp: cntp; \
BEGIN (*LEAVEBODY*)
IF debug THEN put←linenumber;
IF fprocp <> NIL THEN (* IF LEAVING THE BODY OF A PROC/FUNC*)
BEGIN
macro4(541B(*HRRI*),topp,basis,0);
macro4(547B(*HLRS*),basis,topp,-1);
macro3(263B(*POPJ*),topp,0)
END
ELSE (* FPROCP = NIL <=> LEAVING MAIN BODY.*)
BEGIN
%13 (* 14.*)
IF NOT external THEN
(* 14.*) \
BEGIN
close←files;
IF counting THEN (* 28. CALL THE RUNTIME THAT DUMPS THEM*)
BEGIN
FOR i := 1 TO 6 DO
kntname[i] := source←file[i];
kntname[7] := 'K';
kntname[8] := 'N';
kntname[9] := 'T';
alfaconstant(kntname);
gattr.cval.valp↑.cclass := strd;
macro2(200B(*MOVE*),regin+2);
macro2(200B(*MOVE*),regin+1);
deposit←constant(strd,gattr);
endofcounts := lcmain - 2;
macro3r(551B(*HRRZI*),regin+3,startofcounts);
macro3r(551B(*HRRZI*),regin+4,endofcounts);
support(dumpcounts);
%13
FOR i := 1 TO 9 DO
BEGIN
lpcross←file[i] := pcross←file[i];
IF i <= 6 THEN
lpcross←device[i] := pcross←device[i]
ELSE
lpcross←device[i] := ' ';
END;
lpcross←file[10] := ' ';
lpcross←device[10] := ' ';
\
%24
END;
IF cross←reference THEN (* 21.*)
BEGIN
alfaconstant(pcross←file);
(* 21.*) \
%13 alfaconstant(lpcross←file); \
macro2(551B(*HRRZI*),regin+1);
deposit←constant(strg,gattr);
%24 alfaconstant(pcross←device); \
%13 alfaconstant(lpcross←device); \
macro2(551B(*HRRZI*),regin+2);
deposit←constant(strg,gattr);
macro3r(551B(*HRRZI*),regin+3,pcross←ppn);
macro3r(551B(*HRRZI*),regin+4,pcross←core);
support(runprogram);
END;
%13 (* 14.*)
IF library[fortransy].called AND fortran←enviroment THEN
BEGIN (* FORTRAN-STYLE I/O *)
macro3r(551B(*HRRZI*),regin + 1,stdfileptr[4]↑.vaddr);
support(putbuffer);
macro3(551B(*HRRZI*),basis,ic+3);
support(fortranexit);
generate←word(no,0,0);
generate←word(no,0,0)
END
ELSE
(* 14.*) \
support(exitprogram);
start←address := ic;
macro3(255B(*JFCL*),0,runcore*1024); (* START-UP CODE: REPORT LOWCORE SIZE,*)
macro3(554B(*HLRZ*),basis,jbsa); (* SET THE STACK FRAME *)
macro4(505B(*HRLI*),basis,basis,0);
macro4(541B(*HRRI*),topp,basis,0); (* AND THE STACK POINTER *)
stacksize1 := cix; stacksize2 := cix;
macro3r(550B(*HRRZ*),reg1,start←address); (* CHECK FOR MEMORY SPACE CONFLICTS *)
macro3(317B(*CAMG*),reg1,jbrel);
macro3r(254B(*JRST*),0,ic+3);
macro3(047B,reg1,11B(*CORE-UUO*));
support(nocoreavailable);
macro3(200B(*MOVE*),newreg,jbrel);
macro4(307B(*CAIG*),newreg,topp,40B);
support(stackoverflow);
macro3(506B(*HRLM*),newreg,jbsa);
macro3(275B(*SUBI*),newreg,1);
macro3(505B(*HRLI*),topp,400000B);
macro3(047B,reg0,0(*RESET-UUO*));
%13 (* 14. NO LIBRARIES NEEDED IN PASSGO.*)
IF library[fortransy].called AND fortran←enviroment THEN
BEGIN (* SET-UP FOR FORTRAN-STYLE I/O *)
macro4(202B(*MOVEM*),newreg,newreg,0);
macro4(202B(*MOVEM*),basis,newreg,-1);
macro4(202B(*MOVEM*),topp,newreg,-2);
support(fortranreset);
generate←word(no,0,0);
macro3(554B(*HLRZ*),reg1,jbsa);
macro4(200B(*MOVE*),newreg,reg1,-1);
macro4(200B(*MOVE*),basis,reg1,-2);
macro4(200B(*MOVE*),topp,reg1,-3)
END;
(* 14.*) \
IF NOT debug AND runtime←check THEN
BEGIN
macro3(551B(*HRRZI*),reg1,110B); (*ENABLE OVERFLOW*)
macro3(047B,reg1,16B(*APRENB-UUO*))
END
END;
regc := regin + 1; lparmptr := parmptr;
IF %13 external OR \ (parmptr = NIL) (* 14.*) THEN
BEGIN
alfaconstant(programname);
name←address := ic;
macro2(551B(*HRRZI*),regc+2); deposit←constant(strg,gattr)
END;
%13 (* 14.*)
IF NOT external THEN
(* 14.*) \
BEGIN
IF parmptr <> NIL THEN
name←address := ic;
WHILE lparmptr <> NIL DO
WITH lparmptr↑ DO
BEGIN
IF fileidptr <> NIL THEN
WITH fileidptr↑ DO (* CODE TO CALL GETPARAMETER FOR THE FILE NAMES.*)
BEGIN
alfaconstant(programname);
macro2(551B(*HRRZI*),regc+2); deposit←constant(strg,gattr);
macro3r(551B(*HRRZI*),regc,vaddr);
alfaconstant(name);
macro2(551B(*HRRZI*),regc+1); deposit←constant(strg,gattr);
IF NOT inputfile THEN
macro2(400B(*SETZ*),regc+3)
ELSE
macro3(551B(*HRRZI*),regc+3,1);
support(readpgmparameter)
END
ELSE
error←with←text(264,fileid);
lparmptr := nextptp
END;
%24 (* 21. CALL TO SETTIME *)
support(startclock);
(* 21.*) \
FOR i := 1 TO 4 DO macro2(400B(*SETZ*),regc+i);
IF NOT inputpar THEN (* OPEN FILE INPUT IF NOT DECLARED AS PARAMETER *)
BEGIN
macro3r(551B(*HRRZI*),regc,stdfileptr[1]↑.vaddr);
support(resetfile);
END;
IF outputwrite AND NOT outputpar THEN (* 13. REWRITE OUTPUT ONLY IF NEEDED.*)
BEGIN
macro3r(551B(*HRRZI*),regc,stdfileptr[2]↑.vaddr);
support(rewritefile);
END;
macro3r(551B(*HRRZI*),regc,stdfileptr[4]↑.vaddr); (* OPEN TTYOUTPUT *)
macro4(336B(*SKIPN*),0,regc,filbhp);
support(rewritefile);
IF ttyread THEN (* OPEN TTY, IF NEEDED.*)
BEGIN
support(opentty);
alfaconstant('TTY ');
macro2(551B(*HRRZI*),regc+1); deposit←constant(strg,gattr);
macro3r(551B(*HRRZI*),regc,stdfileptr[3]↑.vaddr);
macro4(200B(*MOVE*),regc+5,regc,fildev);
macro3(302B(*CAIE*),regc+5,tty←sixbit);
macro3(550B(*HRRZ*),regc+4,regc+1);
support(resetfile)
END;
%24
IF counting THEN (* 28. PUT THEIR VALUES IN MEMORY*)
BEGIN
laddress := startofcounts;
lcntp := firstcntp;
WHILE lcntp <> NIL DO
WITH lcntp↑ DO (*FOR EACH SET OF 100*)
BEGIN
IF next = NIL THEN
counttop := counter - 1
ELSE
counttop := 100;
FOR index := 1 TO counttop DO (*FOR EACH BASIC BLOCK*)
BEGIN
macro3(505B(*HRLI*),regin,lineinfo[index].line);
macro3(541B(*HRRI*),regin,lineinfo[index].page);
macro4(202B(*MOVEM*),regin,0,laddress);
macro4(402B(*SETZM*),0,0,laddress+1);
laddress := laddress + 2;
END;
lcntp := next;
END;
END;
\
macro3(552B(*HRRZM*),basis,debug←stackbottom + system←low←start);
macro3(332B(*SKIPE*),reg0,debug←initialization + system←low←start);
macro3(256B(*XCT*),reg0,debug←initialization + system←low←start);
macro3r(254B(*JRST*),reg0,main←start);
IF debug THEN support(loaddebug)
END
END;
codeend := ic;
lksp:= firstkonst; (* VALUES OF THE CONSTANTS *)
WHILE lksp <> NIL DO
WITH lksp↑,constptr↑ DO
BEGIN
kaddr:= ic;
WITH icchange DO
BEGIN
icval := ic; selfcsp :=iccsp
END;
nocode := false;
CASE cclass OF
int,
bptr,
reel:
ic := ic + 1 ;
pset:
ic := ic + 2 ;
strd,
strg:
ic := ic + (slgth+4) DIV 5
END (*CASE*);
lksp := nextkonst
END (*WITH , WHILE*);
ldeclscalptr := declscalptr; (* DESCRIPTION OF THE SCALARS *)
WHILE ldeclscalptr <> NIL DO
WITH ldeclscalptr↑ DO
IF (level = tlev) OR ((level = 1) AND (tlev = 0)) THEN
BEGIN
IF request THEN
BEGIN
ic := ic+2*dimension; vectoraddr := ic; ic := ic + 2
END;
ldeclscalptr := nextscalar
END
ELSE ldeclscalptr := NIL;
IF debug←switch THEN
BEGIN
lcp := display[top].fname;
IF (level > 1) AND ( lcp <> NIL ) THEN
BEGIN
IF lcp↑.selfctp = NIL THEN i:= ic
ELSE i := ord(lcp↑.selfctp);
insert←address(right,idtree,i)
END
END;
IF level = 1 THEN highest←code := ic
END(*LEAVEBODY*);
(*fetch←basis,get←parameter←address,generate←code,load,store,load←address*)
PROCEDURE fetch←basis(VAR fattr: attr); (* CODE TO PUT IN INDEXR THE BASIS OF A SUBSTRUCTURE *)
VAR
p,q: integer;
BEGIN (*FETCH←BASIS*)
WITH fattr DO
IF vlevel>1 THEN
BEGIN
p := level - vlevel;
IF p=0 THEN
IF indexr=0 THEN indexr := basis
ELSE macro3(270B(*ADD*),indexr,basis)
ELSE
BEGIN
macro4(550B(*HRRZ*),reg1,basis,-1);
FOR q := p DOWNTO 2 DO
macro4(550B(*HRRZ*),reg1,reg1,-1);
IF indexr=0 THEN indexr := reg1
ELSE macro4(271B(*ADDI*),indexr,reg1,0)
END;
(*WITHIN A WITH-STATEMENT, THERE IS THE POSSIBILITY THAT
FETCH←BASIS WILL BE ACTIVATED TWO TIMES*)
vlevel := 1
END
END (*FETCH←BASIS*);
PROCEDURE get←parameter←address; (*CODE TO LOAD THE ADDRESS OF A FORMAL PARAMETER*)
BEGIN (*GET←PARAMETER←ADDRESS*)
fetch←basis(gattr);
WITH gattr DO
BEGIN
increment←regc;
macro5(vrelbyte,200B(*MOVE*),regc,indexr,dplmt);
indexr := regc; vrelbyte:= no;
indbit := 0; vlevel := 1; dplmt := 0
END
END (*GET←PARAMETER←ADDRESS*);
PROCEDURE generate←code(finstr: instrange; fac: acrange; VAR fattr: attr);
VAR
linstr: instrange;
lregc: acrange;
lattr: attr;
lrelbyte: relbyte;
labs: integer;
BEGIN (*GENERATE←CODE*)
lrelbyte := right;
WITH fattr DO
IF typtr<>NIL THEN
BEGIN
CASE kind OF
cst:
IF typtr=realptr THEN
BEGIN
macro3(finstr,fac,0); deposit←constant(reel,fattr)
END
ELSE
IF typtr↑.form=scalar THEN
WITH cval DO
BEGIN
IF ival = -maxint - 1 THEN labs := maxint
ELSE labs := abs(ival);
IF ((ival >= 0) AND (ival <= maxaddr))
OR
((labs <= hwcstmax+1) AND (finstr = 200B(*MOVE*))) THEN
BEGIN
IF finstr=200B(*MOVE*) THEN
IF ival < 0 THEN finstr := 561B(*HRROI*)
ELSE finstr := 551B(*HRRZI*)
ELSE
IF (finstr>=311B) AND (finstr <= 317B) THEN finstr := finstr - 10B (*E.G. CAML --> CAIL*)
ELSE finstr := finstr+1;
macro3(finstr,fac,ival)
END
ELSE
BEGIN
macro3(finstr,fac,0); deposit←constant(int,fattr)
END
END
ELSE
IF typtr=nilptr THEN
BEGIN
IF finstr=200B(*MOVE*) THEN finstr := 551B(*HRRZI*)
ELSE
IF (finstr>=311B) AND (finstr<=317B) THEN finstr := finstr-10B
ELSE finstr := finstr+1;
macro3(finstr,fac,377777B)
END
ELSE
IF typtr↑.form=power THEN
BEGIN
macro3(finstr,fac,0); macro3(finstr,fac-1,0); deposit←constant(pset,fattr)
END
ELSE
IF typtr↑.form=arrays THEN
IF typtr↑.size = 1 THEN
BEGIN
macro3(finstr,fac,0); deposit←constant(strg,fattr)
END
ELSE
IF typtr↑.size = 2 THEN
BEGIN
fattr.cval.valp↑.cclass := strd;
macro3(finstr,fac,0); macro3(finstr,fac-1,0); deposit←constant(strd,fattr)
END;
varbl:
BEGIN
fetch←basis(fattr); lregc := fac;
IF (indexr>regin) AND (indexr<=regcmax) AND ((packfg<>notpack) OR (finstr=200B(*MOVE*))) THEN
IF (typtr↑.size = 2) AND loadnoptr THEN lregc := indexr+1
ELSE lregc := indexr
ELSE
IF (packfg<>notpack) AND (finstr<>200B(*MOVE*)) THEN
BEGIN
increment←regc; lregc := regc
END;
CASE packfg OF
notpack:
BEGIN
IF (typtr↑.size = 2) AND loadnoptr THEN
BEGIN
macro5(vrelbyte,finstr,lregc,indexr,dplmt+1);
macro5(vrelbyte,finstr,lregc-1,indexr,dplmt)
END
ELSE macro(vrelbyte,finstr,lregc,indbit,indexr,dplmt)
END;
packk:
BEGIN
IF vclass = field THEN
BEGIN
WITH lattr, cval, byte DO
BEGIN
kind := cst;
cval.byte := fattr.vbyte;
ibit := ord(fattr.vrelbyte);
ireg := fattr.indexr;
reladdr := reladdr + fattr.dplmt
END;
macro2(135B(*LDB*),lregc); deposit←constant(bptr,lattr)
END
ELSE
BEGIN
macro5(vrelbyte,551B(*HRRZI*),reg1,indexr,dplmt);
IF (bpaddr>regin) AND (bpaddr<=regcmax) THEN
IF (indexr<=regin) OR (bpaddr<indexr) THEN lregc := bpaddr
ELSE lregc := indexr;
IF bpaddr < high←start THEN lrelbyte := no;
macro5(lrelbyte,135B(*LDB*),lregc,0,bpaddr)
END
END;
hwordl:
macro5(vrelbyte,554B(*HLRZ*),lregc,indexr,dplmt);
hwordr:
macro5(vrelbyte,550B(*HRRZ*),lregc,indexr,dplmt)
END (*CASE*);
IF (finstr<>200B(*MOVE*)) AND (packfg<>notpack) THEN macro3(finstr,fac,lregc)
ELSE fac := lregc
END;
expr:
IF finstr <> 200B(*MOVE*) THEN
BEGIN
macro3(finstr,fac,reg);
IF typtr↑.size = 2 THEN macro3(finstr,fac-1,reg-1)
END
END (*CASE*);
kind := expr; reg := fac
END
END (*GENERATE←CODE*);
PROCEDURE load(VAR fattr: attr); (*CODE TO PUT THE VALUE OF FATTR IN A REGISTER*)
VAR
linstr: instrange;
BEGIN (*LOAD*)
WITH fattr DO
IF typtr<>NIL THEN
IF kind<>expr THEN
BEGIN
increment←regc ; linstr := 200B(*MOVE*);
IF (typtr↑.size = 2) AND loadnoptr THEN increment←regc ;
generate←code(linstr,regc,fattr); regc := reg
END
END (*LOAD*) ;
PROCEDURE store(fac: acrange; VAR fattr: attr); (*CODE TO STORE IN MEMORY THE VALUE IN FAC*)
VAR
lattr: attr; lattrc: attr; lrelbyte: relbyte;
BEGIN (*STORE*)
lattr := fattr; lrelbyte := right;
WITH lattr DO
IF typtr <> NIL THEN
BEGIN
fetch←basis(lattr);
CASE packfg OF
notpack:
BEGIN
IF typtr↑.size = 2 THEN
BEGIN
macro5(vrelbyte,202B(*MOVEM*),fac,indexr,dplmt+1); fac := fac-1
END;
macro(vrelbyte,202B(*MOVEM*),fac,indbit,indexr,dplmt)
END;
packk:
IF vclass = field THEN
BEGIN
WITH lattrc, cval, byte DO
BEGIN
kind := cst;
cval.byte := lattr.vbyte;
ibit := ord(lattr.vrelbyte);
ireg := lattr.indexr;
reladdr := reladdr + lattr.dplmt
END;
macro2(137B(*DPB*),fac); deposit←constant(bptr,lattrc)
END
ELSE
BEGIN
macro5(vrelbyte,551B(*HRRZI*),reg1,indexr,dplmt);
IF bpaddr < high←start THEN lrelbyte := no;
macro5(lrelbyte,137B(*DPB*),fac,0,bpaddr)
END;
hwordl:
macro5(vrelbyte,506B(*HRLM*),fac,indexr,dplmt);
hwordr:
macro5(vrelbyte,542B(*HRRM*),fac,indexr,dplmt)
END (*CASE*)
END (*WITH*)
END (*STORE*) ;
PROCEDURE load←address; (*CODE TO PUT THE ADDRESS OF GATTR IN A REGISTER*)
BEGIN (*LOAD←ADDRESS*)
increment←regc ;
BEGIN
WITH gattr DO
IF typtr <> NIL THEN
BEGIN
CASE kind OF
cst:
IF string(typtr) THEN
BEGIN
macro3(551B(*HRRZI*),regc,0);
deposit←constant(strg,gattr)
END
ELSE error(171);
varbl:
BEGIN
IF (indexr>regin) AND (indexr <= regcmax) THEN regc := indexr;
fetch←basis(gattr);
CASE packfg OF
notpack:
macro(vrelbyte,551B(*HRRZI*),regc,indbit,indexr,dplmt);
packk,hwordl,hwordr:
error(357)
END;
%13 (* 14. EXTERNAL IS SUPPRESSED FROM PASSGO.*)
IF typtr↑.form = files THEN
IF last←file <> NIL THEN
WITH last←file↑ DO
IF (vlev = 0) AND external THEN
BEGIN
vaddr := ic-1; code←reference↑[cix] := externref
END
(* 14.*) \
END;
expr:
error(171)
END;
kind := varbl; dplmt := 0; indexr:=regc; indbit:=0; vrelbyte := no; vclass := vars
END
END
END (*LOAD←ADDRESS*) ;
(* WRITE←MACHINE←CODE[ AND ITS PARTS. *)
PROCEDURE write←machine←code(write←flag:write←form);
%13 (* 18.*)
TYPE
bigalfa = PACKED ARRAY[1..20] OF char ;
(* 18.*) \
VAR
%13 llist←code, put←code←array: boolean; (* 14.*) \
%13 lic, licmod4: addrrange; (* 18.*) \
space←c, space←w: integer;
%13 (* 14. LIST←CODE DOES NOT GO IN PASSGO.*)
PROCEDURE new←line;
BEGIN (*NEW←LINE*)
licmod4 := lic MOD 4;
IF (licmod4 = 0) AND list←code AND (lic > 0) THEN
BEGIN
writeln(list);
WITH relocation←block DO
BEGIN
IF item = item←1 THEN write(list, lic:6:o, showrelo[relocator[0] = right])
ELSE write(list,' ':7)
END
END
END (*NEW←LINE*) ;
PROCEDURE put←relocatable←code; (* 18.*)
VAR
i: integer;
BEGIN (*PUT←RELOCATABLE←CODE*)
WITH relocation←block DO
BEGIN
IF ((count > 1) OR (item <> item←1)) AND (count > 0) THEN
BEGIN
FOR i:= count+1 TO 18 DO relocator[i-1] := no;
FOR i:= 1 TO count+2 DO
BEGIN
object↑:= component[i];
put(object)
END
END;
count := 0
END
END (*PUT←RELOCATABLE←CODE*);
PROCEDURE write←block←start(frelbyte: relbyte; flic: addrrange; fitem: addrrange);
VAR
change: PACKED RECORD
CASE boolean OF
true: (wkonst: integer);
false:(wlefthalf: addrrange; wrighthalf: addrrange)
END;
BEGIN (*WRITE←BLOCK←START*)
WITH relocation←block , change DO
BEGIN
IF count <> 0 THEN put←relocatable←code;
item := fitem;
lic := flic;
IF item = item←1 THEN
BEGIN
wlefthalf:= 0;
wrighthalf:= lic;
code[0]:= wkonst;
relocator[0] := frelbyte;
count:= 1
END
END
END (*WRITE←BLOCK←START*);
(* 18. PASCAL VERSION OF WRITE←WORD.*)
PROCEDURE write←word(frelbyte: relbyte; fword: integer);
VAR
change: PACKED RECORD
CASE boolean OF
true: (wkonst: integer);
false:(wlefthalf: addrrange; wrighthalf: addrrange)
END;
BEGIN (*WRITE←WORD*)
WITH change DO
BEGIN
wkonst := fword;
WITH relocation←block DO
BEGIN
IF count = 0 THEN write←block←start(relocator[0],lic,item);
code[count]:= fword;
IF NOT put←code←array THEN
BEGIN
IF frelbyte IN [left,both] THEN
IF (wlefthalf = 0) OR (wlefthalf = 377777B) THEN
IF frelbyte = both THEN frelbyte := right
ELSE frelbyte := no;
IF frelbyte IN [right,both] THEN
IF (wrighthalf = 0) OR (wrighthalf = 377777B) THEN
IF frelbyte = both THEN frelbyte := left
ELSE frelbyte := no
END;
relocator[count]:= frelbyte;
count := count+1;
IF count = 18 THEN put←relocatable←code
END;
IF llist←code THEN
BEGIN
new←line;
IF lic > 0 THEN
IF licmod4 = 0 THEN write(list,' ':13)
ELSE write(list,' ':11,' ':space←w);
IF write←flag > write←fileblocks THEN write(list,' ':7)
ELSE write(list,wlefthalf:6:o, showrelo[ frelbyte IN [left,both] ] );
write(list,wrighthalf:6:o, showrelo[ frelbyte IN [right,both] ], ' ':3)
END;
lic := lic + 1;
space←w := 2
END
END (*WRITE←WORD*);
(* 18.*) \
%24 (* 18. PASSGO VERSION OF WRITE←WORD.*)
PROCEDURE write←word (fword: integer);
BEGIN
userprog.execode [execodecount] := fword;
execodecount := execodecount + 1;
IF execodecount > maxcode THEN
begin
error (412);
execodecount := 1;
end;
space←w := 2;
END;
(* 18.*) \
%13 (* 18.*)
FUNCTION radix50( fname: alfa): radixrange;
VAR
i: integer; c: char; octalcode, radixvalue: radixrange;
BEGIN (*RADIX50*)
radixvalue:= 0;
i:=1; c := fname[1];
WHILE (c <> ' ') AND (i <= 6) DO
BEGIN
IF c IN digits THEN octalcode:= ord(c)-ord('0')+1
ELSE
IF c IN letters THEN octalcode:= ord(c)-ord('A')+11
ELSE
IF c = '.' THEN octalcode:= 37
ELSE
IF c = '$' THEN octalcode:= 38
ELSE
IF c = '%' THEN octalcode:= 39;
radixvalue:= radixvalue*50B+octalcode; i:=i+1; c := fname[i]
END;
radix50:= radixvalue
END (*RADIX50*);
(* 18.*) \
PROCEDURE write←pair( %13 frelbyte: relbyte; \ faddr1, faddr2: addrrange); (* 18.*)
BEGIN (*WRITE←PAIR*)
WITH change DO
BEGIN
wlefthalf:= faddr1;
wrighthalf:= faddr2;
write←word( %13 frelbyte, \ wkonst) (* 18.*)
END
END (*WRITE←PAIR*);
%13 (* 18.*)
PROCEDURE write←identifier( fflag: flagrange; fsymbol: alfa);
BEGIN (*WRITE←IDENTIFIER*)
llist←code := false;
WITH change DO
BEGIN
IF list←code AND (write←flag > write←hiseg) THEN
BEGIN
IF lic > 0 THEN
BEGIN
IF lic MOD 4 = 0 THEN
BEGIN
writeln(list); write(list,' ':7)
END;
write(list,' ':13)
END;
write(list,fsymbol:6,' ':11)
END;
IF fflag <> sixbit←symbol THEN
BEGIN
flag:= fflag; symbol:= radix50(fsymbol)
END;
write←word(no,wkonst);
llist←code := list←code
END
END (*WRITE←IDENTIFIER*);
PROCEDURE write←first←line ;
BEGIN (*WRITE←FIRST←LINE*)
IF list←code THEN
BEGIN
writeln(list);
licmod4 := lic MOD 4;
IF licmod4 > 0 THEN
write(list,(lic-licmod4):6:o,showrelo[relocation←block.relocator[0] = right],' ':licmod4*30)
END
END (*WRITE←FIRST←LINE*);
PROCEDURE write←header(ftext: bigalfa);
BEGIN (*WRITE←HEADER*)
IF list←code THEN
BEGIN
writeln(list); writeln(list); write(list,ftext:16,':',' ':3); lic := 0
END
END (*WRITE←HEADER*);
(* 18.*) \
PROCEDURE write←constant(fcst: cstclass);
VAR
i, j: integer; lrelbyte: relbyte;
BEGIN (*WRITE←CONSTANT*)
WITH change DO
BEGIN
IF (fcst = bptr) AND (wbyte.ibit <> 0) THEN
BEGIN
wbyte.ibit := 0; lrelbyte := right
END
ELSE lrelbyte := no;
%13 (* 14. LIST←CODE IS NOT IN PASSGO.*)
IF list←code THEN
BEGIN
new←line;
IF licmod4 = 0 THEN write(list,' ':8)
ELSE write(list,' ':6,' ':space←c);
CASE fcst OF
int:
write(list,'[',' ':10,wkonst,']');
reel:
write(list,'[',' ':5,wreal,']');
strd,
strg:
BEGIN
write(list,'[',' ':15,''''); j := 0;
FOR i := 1 TO 5 DO
IF NOT (wstring[i] IN [' '..'←']) THEN j := j + 1
ELSE write(list,wstring[i]);
write(list,'''',' ':j,']')
END;
pset:
write(list,'[',' ':10,wkonst:12:o,']');
bptr:
WITH wbyte DO
write(list, 'POINT ', sbits:2, ', ',
reladdr:5:o, showrelo[(lrelbyte = right)], '(',
ireg:2:o, '),', 35-pbits:2)
END
END;
(* 14.*) \
write←word( %13 lrelbyte, \ wkonst); (* 18.*)
space←c := 0
END
END (*WRITE←CONSTANT*);
PROCEDURE code←for←fileblocks;
VAR
stopptr, lfileptr: ftp;
i: integer;
filblockadr: addrrange;
%24 atastdfile: boolean; (* 21.*) \
(* IMPLEMENTATION OF FILES IN DECSYSTEM-10 PASCAL
FILE TYPE PACKED UNPACKED
------------------------------------------------
(SUBRANGE OF) ASCII-MODE, BINARY-MODE,
CHAR FORMATTED I/O, STANDARD I/O,
"UPPER CASE", "FULL BOARD"
LINENUMBERS &
PAGEMARKS
(SUBRANGE OF) ASCII-MODE, AS ABOVE
ASCII STANDARD I/O,
. "FULL BOARD"
OTHER TREATED AS ABOVE
. AS UNPACKED
*)
BEGIN (*CODE←FOR←FILEBLOCKS*)
lfileptr:= fileptr;
%13 (* 14. *)
IF NOT external THEN stopptr := NIL
ELSE
stopptr := sfileptr;
(* 14.*) \
%24 (* 21.*)
stopptr := NIL;
atastdfile := lfileptr = sfileptr;
(* 21.*) \
WHILE lfileptr <> stopptr DO
WITH lfileptr↑, fileident↑, change DO
IF idtype=NIL THEN
BEGIN
error(171); lfileptr:=stopptr
END
ELSE
BEGIN
%24 (* 21.*)
IF atastdfile THEN
execodecount := vaddr - system←low←start
ELSE
execodecount := vaddr - userareastart;
(* 21.*) \
filblockadr := vaddr;
%13 write←block←start(right,filblockadr,item←1); (* 18.*) \
%13 write←first←line; (* 14.*) \
wlefthalf := idtype↑.file←form;
wrighthalf := filblockadr + filcmp;
write←word( %13 right, \ wkonst) ; (* 18.*)
write←word( %13 no, \ 0) ; write←word( %13 no, \ 0) ; (*RESERVE LOCATIONS FOR FILEOF AND FILEOL*) (* 18.*)
wkonst := 0;
winstr.instr := 50B (*OPEN*) ; winstr.ac := channel ;
winstr.address := filblockadr + filsta ;
write←word( %13 right, \ wkonst) (*FILOPN*) ; (* 18.*)
winstr.instr := 76B (*LOOKUP*) ; winstr.address := filblockadr + filnam ;
write←word( %13 right, \ wkonst) ; (* 18.*)
winstr.instr := 77B (*ENTER*) ;
write←word( %13 right, \ wkonst) ; (* 18.*)
winstr.address := 0 ;
winstr.instr := 56B (* IN*) ; write←word( %13 no, \wkonst) ; (* 18.*)
winstr.instr := 57B (*OUT*) ; write←word( %13 no, \wkonst) ; (* 18.*)
winstr.instr := 70B (*CLOSE*) ; write←word( %13 no, \wkonst) ; (* 18.*)
write←word( %13 no, \ idtype↑.file←mode); (* 18.*)
IF (name = 'TTYOUTPUT ') OR (name = 'TTY ') THEN wlefthalf := tty←sixbit
ELSE wlefthalf := dsk←sixbit;
wrighthalf := 0;
write←word( %13 no, \ wkonst); (* 18.*)
write←word( %13 no, \ 0) ; (*BUFFERHEADER ADDRESS INSERTED DURING RESET OR REWRITE*) (* 18.*)
FOR i := 1 TO 6 DO wsixbit[i] := ord( name[i] ) - 40B ;
write←word( %13 no, \ wkonst) ; (* 18.*)
wkonst := 0 ;
FOR i := 1 TO 3 DO wsixbit[i] := ord( name[i+6] ) - 40B ;
write←word( %13 no, \ wkonst) ; (* 18.*)
FOR i := 1 TO 6 DO write←word( %13 no, \ 0 ) (*ZERO IN FILPROT, FILPPN, FILBFH, FILBTP, FILBTC,FILLNR*) ;
(* 18.*)
wlefthalf := - idtype↑.filtype↑.size ; wrighthalf := filblockadr + filcmp ;
write←word( %13 right, \ wkonst) (*FILCNT*) ; (* 18.*)
FOR i := 1 TO idtype↑.filtype↑.size DO write←word( %13 no, \ 0 ) (*CLEAR COMPONENT LOCATIONS *) ;
(* 18.*)
lfileptr := nextftp;
%24 (* 21.*)
IF lfileptr = sfileptr THEN
atastdfile := true;
(* 21.*) \
END;
END (*CODE←FOR←FILEBLOCKS*);
PROCEDURE code←for←instructions;
VAR
i, j, nn: integer;
lbyte: bpointer; ldeclscalptr: stp; lfconst: ctp;
lrelbyte: relbyte; lfirstkonst: ksp; lreference: coderefs;
string: ARRAY[1..6] OF char;
BEGIN (*CODE←FOR←INSTRUCTIONS*)
%13 (* 14. LIST←CODE NOT IN PASSGO.*)
llist←code:= false;
IF list←code THEN writebuffer;
(* 14.*) \
IF lastbtp <> NIL THEN (* WRITE THE BYTEPOINTERS *)
BEGIN
%13 write←block←start(right,lastbtp↑.arraysp↑.arraybpaddr,item←1); (* 18.*) \
%13 write←first←line; (* 14.*) \
WHILE lastbtp <> NIL DO
BEGIN
WITH lastbtp↑, arraybps[bitsize] DO
BEGIN
lbyte := abyte;
IF state = calculated THEN
BEGIN
nn := bytemax; state:= used
END
ELSE nn:=0
END;
FOR i:=1 TO nn DO
BEGIN
WITH change DO
BEGIN
wbyte := lbyte; write←constant(bptr)
END;
WITH lbyte DO pbits := pbits - sbits
END (*FOR*);
lastbtp := lastbtp↑.last
END (* WHILE*)
END (*LASTBTP<>NIL*) ;
%13 (* 14. AND 18.*)
put←code←array := true; (* WRITE THE INSTRUCTION CODE *)
write←block←start(right,codeend-cix-1,item←1);
write←first←line;
IF list←code AND (licmod4 <> 0) THEN write(list,' ':2);
(* 14. AND 18.*) \
FOR i := 0 TO cix DO
WITH code←array↑, instruction[i] DO
BEGIN
lrelbyte := code←relocation↑[i];
lreference := code←reference↑[i];
IF (lreference IN [externref,constref,forwardref,gotoref,pointref,saveref,debugref]) AND (address = 0) THEN lrelbyte := no;
%13 (* 14.*)
IF list←code THEN
BEGIN
new←line;
IF licmod4 = 0 THEN write(list,' ':8)
ELSE write(list,' ':6);
CASE lreference OF
noinstr:
WITH halfword[i] DO
write(list,' ':5,lefthalf :6:o, showrelo[lrelbyte IN [left,both]],
righthalf:6:o, showrelo[lrelbyte IN [right,both]],' ':5);
OTHERS:
BEGIN
unpack(mnemonics[(instr+9) DIV 10],string,1,((instr+9) MOD 10)*6+1,6);
write(list,string:6, ' ',ac:2:o,', ', showibit[indbit],
address:6:o, showrelo[lrelbyte IN [right,both]]);
IF inxreg > 0 THEN write(list,'(',inxreg:2:o,')',showref[lreference])
ELSE write(list,' ':4,showref[lreference])
END
END (*CASE*)
END;
(* 14.*) \
write←word( %13 lrelbyte, \ word[i]) (* 18.*)
END (*FOR *) ;
%13 put←code←array := false; (* 18.*) \
IF (firstkonst <> NIL) OR (declscalptr <> NIL) THEN
BEGIN (* WRITE THE VALUES OF THE CONSTANTS *)
lfirstkonst := firstkonst;
%13 (* 14. AND 18.*)
write←block←start(right,lic,item←1);
write←first←line;
IF list←code AND (licmod4 <> 0) THEN write(list,' ':2);
(* 14. AND 18.*) \
WHILE lfirstkonst <> NIL DO
BEGIN
WITH lfirstkonst↑.constptr↑, change DO
BEGIN
CASE cclass OF
int,
reel:
wkonst := intval;
pset:
BEGIN
wkonst := intval; write←constant(cclass);
wkonst := intval1
END;
bptr:
wbyte := byte;
strd,
strg:
BEGIN
j :=0; wkonst := 0;
FOR i := 1 TO slgth DO
BEGIN
j := j+1;
wstring[j] := sval[i];
IF j=5 THEN
BEGIN
j := 0;
write←constant(cclass);
wkonst := 0
END
END
END
END;
IF NOT (cclass IN [strd,strg]) OR (j <> 0) THEN write←constant(cclass)
END;
lfirstkonst := lfirstkonst↑.nextkonst
END (*WHILE*) ;
ldeclscalptr := declscalptr; (* WRITE THE DESCRIPTIONS OF SCALARS *)
WHILE ldeclscalptr <> NIL DO
WITH ldeclscalptr↑ DO
IF (level = tlev) OR ((level = 1) AND (tlev = 0)) THEN
BEGIN
IF request THEN
BEGIN
lfconst := fconst;
WHILE lfconst <> NIL DO
WITH lfconst↑ DO
BEGIN
FOR j := 0 TO 1 DO
WITH change DO
BEGIN
wkonst := 0;
FOR i := 1 TO 5 DO
wstring[i] := name[i+j*5];
write←constant(strd)
END;
lfconst := next
END
END;
ldeclscalptr := nextscalar
END
ELSE ldeclscalptr := NIL
END;
IF level = 1 THEN
BEGIN
jump←address := lcmain;
lcmain := lcmain + 2 * jumper
END;
IF NOT debug AND (level = 1) THEN
BEGIN
%13 (* 14.*)
llist←code := list←code;
IF list←code THEN
BEGIN
writeln(list); write(list,debug←save:6:o,'''',' ':13)
END;
(* 14.*) \
%13 write←block←start(right,debug←save,item←1); (* 18.*) \
FOR i := debug←save TO debug←programname DO
write←word( %13 no, \ 0) (* 18.*)
END
END (*CODE←FOR←INSTRUCTIONS*);
%13 (* 14.*)
PROCEDURE code←for←globals;
VAR
i, j: integer;
BEGIN (*CODE←FOR←GLOBALS*)
IF list←code AND (fglobptr <> NIL) THEN writebuffer;
WHILE fglobptr <> NIL DO
WITH fglobptr↑ DO
BEGIN
j := fcix ;
write←block←start(right,firstglob,item←1);
write←first←line;
FOR i := firstglob TO lastglob DO
BEGIN
change.winstr := code←array↑.instruction[j] ; j := j + 1 ;
write←word(no,change.wkonst)
END ;
fglobptr := nextglobptr
END
END (*CODE←FOR←GLOBALS*);
(* 14.*) \
PROCEDURE code←for←debug;
CONST
maxsize (*OF CONSTANT-, STRUCTURE-, AND IDENTIFIER-RECORD*) = 24 (*WORDS*) ;
TYPE
recordform = (unspecific, const←rec, struct←rec,
ident←rec, debug←rec);
VAR
lnlk : nlk;
lcp: ctp;
lsize: 1..maxsize; run1: boolean;
relarray, relempty: ARRAY[1..maxsize] OF relbyte;
icchange: PACKED RECORD
CASE integer OF
1:(icval: addrrange);
2:(iccsp: csp);
3:(icctp: ctp);
4:(icstp: stp)
END;
recordchange: PACKED RECORD
CASE recordform OF
unspecific: (word:ARRAY[1..maxsize] OF integer);
const←rec: (string1: PACKED ARRAY[1..strglgth] OF char);
struct←rec: (structrec: structure);
ident←rec: (identrec: identifier);
debug←rec: (debugrec: debentry)
END;
PROCEDURE write←record(record←form: recordform);
VAR
i, j: integer;
BEGIN (*WRITE←RECORD*)
%13 llist←code := false; (* 14.*) \
space←c := 2;
CASE record←form OF
ident←rec :
j := 2;
const←rec :
j := lsize;
OTHERS :
j := 0;
END;
IF j <> 0 THEN
BEGIN
FOR i := 1 TO j DO
BEGIN
change.wkonst := recordchange.word[i];
write←constant(strg)
END;
space←w := 0
END;
%13 llist←code := list←code; (* 14.*) \
FOR i := j + 1 TO lsize DO write←word( %13 relarray[i], \ recordchange.word[i] ) (* 18.*)
END (*WRITE←RECORD*);
PROCEDURE copycsp(fcsp:csp);
BEGIN (*COPYCSP*)
IF fcsp <> NIL THEN
WITH fcsp↑ DO
BEGIN
IF cclass IN [strg,strd] THEN lsize := (slgth + 4) DIV 5
ELSE error(171);
IF run1 THEN
BEGIN
IF selfcsp = NIL THEN WITH icchange DO
BEGIN
icval := ic; selfcsp := iccsp;
nocode := true;
ic := ic + lsize
END
END
ELSE
IF nocode THEN
BEGIN
recordchange.string1 := fcsp↑.sval;
relarray := relempty;
write←record(const←rec); nocode := false
END
END (*WITH FCSP↑*)
END (*COPYCSP*);
PROCEDURE copystp(fsp:stp); FORWARD;
PROCEDURE copyctp(fcp:ctp);
BEGIN (*COPYCTP*)
IF fcp <> NIL THEN
WITH fcp↑ DO
IF run1 AND (selfctp=NIL) OR NOT run1 AND nocode THEN
BEGIN
lsize := idrecsize[klass];
IF run1 THEN
WITH icchange DO
BEGIN
icval := ic;
selfctp := icctp; nocode := true;
ic := ic + lsize
END (* RUN1 *)
ELSE
WITH recordchange DO
BEGIN
relarray := relempty;
identrec := fcp↑;
WITH identrec DO
BEGIN
IF llink<>NIL THEN llink:=llink↑.selfctp;
IF rlink<>NIL THEN rlink:=rlink↑.selfctp;
relarray[3] := both;
IF next <>NIL THEN next := next↑.selfctp;
relarray[4] := both;
IF idtype <> NIL THEN
BEGIN
CASE klass OF
konst:
IF idtype↑.form > pointer THEN
BEGIN
values.valp := values.valp↑.selfcsp;
relarray[6] := right
END
ELSE
IF idtype = realptr THEN
BEGIN
change.wreal := values.valp↑.rval;
values.ival := change.wkonst
END;
vars:
BEGIN
IF vlev < 2 THEN relarray[6] := right;
%13 (* 14.*)
WITH fcp↑ DO
IF (idtype↑.form = files) AND (vlev = 0) AND external THEN vaddr := ord(selfctp) + 5
(* 14.*) \
END
END (*CASE*);
idtype := idtype↑.selfstp
END
END;
write←record(ident←rec); nocode := false
END (* RUN2 *);
copyctp(llink);
copyctp(rlink);
copystp(idtype);
copyctp(next);
IF (klass = konst) AND (idtype <> NIL) THEN
IF idtype↑.form > pointer THEN copycsp(values.valp)
END (*WITH FCP↑*)
END (*COPYCTP*);
PROCEDURE copystp;
BEGIN (*COPYSTP*)
IF fsp <> NIL THEN
WITH fsp↑ DO
BEGIN
IF run1 AND (selfstp = NIL) OR NOT run1 AND nocode THEN
BEGIN
lsize := strecsize[form];
IF run1 THEN
WITH icchange DO
BEGIN
nocode:=true;
icval := ic; selfstp := icstp;
ic := ic + lsize
END (* RUN1 *)
ELSE
WITH recordchange DO
BEGIN
relarray := relempty; relarray[2] := right;
structrec := fsp↑;
WITH structrec DO
CASE form OF
scalar:
IF scalkind = declared THEN
IF fconst<>NIL THEN fconst:=fconst↑.selfctp;
subrange:
rangetype:=rangetype↑.selfstp;
pointer:
IF eltype <> NIL THEN eltype := eltype↑.selfstp;
power:
elset := elset↑.selfstp;
arrays:
BEGIN
aeltype := aeltype↑.selfstp;
inxtype := inxtype↑.selfstp; relarray[3] := both
END;
records:
BEGIN
IF fstfld <> NIL THEN fstfld := fstfld↑.selfctp;
IF recvar <> NIL THEN
BEGIN
recvar := recvar↑.selfstp; relarray[3] := left
END
END;
files:
filtype := filtype↑.selfstp;
tagfwithid,
tagfwithoutid:
BEGIN
fstvar := fstvar↑.selfstp;
IF form = tagfwithid THEN tagfieldp := tagfieldp↑.selfctp;
relarray[3] := left
END;
variant:
BEGIN
IF subvar <> NIL THEN subvar := subvar↑.selfstp;
IF firstfield <> NIL THEN firstfield := firstfield↑.selfctp;
relarray[3] := both;
IF nxtvar <> NIL THEN nxtvar := nxtvar↑.selfstp
END
END (*CASE*);
write←record(struct←rec); nocode := false
END (*RUN 2*);
CASE form OF
scalar:
IF scalkind = declared THEN copyctp(fconst);
subrange:
copystp(rangetype);
pointer:
copystp(eltype);
power:
copystp(elset);
arrays:
BEGIN
copystp(aeltype);
copystp(inxtype)
END;
records:
BEGIN
copyctp(fstfld);
copystp(recvar)
END;
files:
copystp(filtype);
tagfwithid,
tagfwithoutid:
BEGIN
copystp(fstvar);
IF form = tagfwithid THEN copyctp(tagfieldp)
END;
variant:
BEGIN
copystp(nxtvar);
copystp(subvar);
copyctp(firstfield)
END
END (*CASE*)
END ;
END (* WITH FSP↑ *)
END (*COPYSTP*);
BEGIN (*CODE←FOR←DEBUG*)
FOR i := 1 TO maxsize DO relempty[i] := no;
IF debug←switch THEN
BEGIN
%13 write←first←line; (* 14.*) \
lcp := display[top].fname;
IF level = 1 THEN
BEGIN
debugentry.globalidtree := ic;
IF lcp<>NIL THEN
IF lcp↑.selfctp <> NIL THEN debugentry.globalidtree := ord(lcp↑.selfctp)
END;
FOR run1 := true DOWNTO false DO copyctp(lcp);
lnlk := globnewlink;
WHILE lnlk <> NIL DO
WITH lnlk↑ DO
BEGIN
IF reftype↑.selfstp = NIL THEN FOR run1 := true DOWNTO false DO copystp(reftype);
lnlk := next
END;
IF level = 1 THEN
BEGIN
debugentry.standardidtree := ic;
FOR run1 := true DOWNTO false DO copyctp(display[0].fname)
END;
END (*DEBUG←SWITCH*);
IF level = 1 THEN
BEGIN
WITH debugentry DO
BEGIN
newpager; lastpageelem := pager;
intpoint := intptr↑. selfstp;
realpoint := realptr↑.selfstp;
boolpoint := boolptr↑.selfstp;
charpoint := asciiptr↑.selfstp
END;
pageheadadr := ic;
FOR i:=1 TO debentry←size DO relarray[i] := right;
recordchange.debugrec := debugentry;
ic := ic + debentry←size;
lsize := debentry←size;
write←record(debug←rec);
highest←code := ic;
%13 (* 14.*)
IF list←code THEN
BEGIN
writeln(list); write(list,debug←save:6:o,'''',' ':13)
END;
(* 14.*) \
%13 write←block←start(right, debug←save,item←1); (* 18.*) \
%24 execodecount := debug←save; (* 21.*) \
write←word( %13 no, \ 0); (* 18.*)
%13 write←pair(no,260740B(*PUSHJ 17,*),0); (* 18.*) \
%24 write←pair(260740B(*PUSHJ 17,*),runtime←support.link[enterdebug]); (* 21.*) \
write←pair( %13 right, \ 0,pageheadadr); (* 18.*)
FOR i := 1 TO 3 DO write←word( %13 no, \ 0);
(* 18.*)
%13 write←pair(no,260740B(*PUSHJ, 17*),0); (* 18.*) \
%24 write←pair(260740B(*PUSHJ, 17*),runtime←support.link[initializedebug]); (* 21.*) \
write←pair( %13 right, \ 0,name←address) (* 18.*)
END (*LEVEL=1*)
END (*CODE←FOR←DEBUG*);
(* PARTS. ]WRITE←MACHINE←CODE. *)
PROCEDURE code←for←control;
VAR
i,j: integer; inlevel: boolean;
checker: ctp;
%24 (* 19. TO BACKPATCH INTERNAL REFERENCES.*)
PROCEDURE walkchain (where, what: addrrange);
VAR
tempwhere: integer;
BEGIN
where := where - userareastart;
WITH userprog DO
WHILE where > 0 DO
BEGIN
tempwhere := exehalfs[where].righthalf - userareastart;
exehalfs[where].righthalf := what;
where := tempwhere;
END;
END (* WALKCHAIN *);
(* 19. END OF BACKPATCHING.*) \
BEGIN (*CODE←FOR←CONTROL*)
%13 (* 18.*)
CASE write←flag OF
write←internals:
BEGIN
write←header('LINK-CHAIN(S) ');
write←block←start(no,0,item←10);
(* 18.*) \
WHILE globnewlink <> NIL DO
WITH globnewlink↑ DO
BEGIN
%13 write←pair( both , refadr , ord( reftype↑.selfstp )); (* 19.*) \
%24 walkchain (refadr, ord(reftype↑.selfstp)); (* 19.*) \
globnewlink := next
END;
inlevel := true;
checker := localpfptr;
WHILE (checker <> NIL) AND inlevel DO
WITH checker↑ DO
IF pflev = level THEN
BEGIN
IF pfaddr <> 0 THEN FOR i := 0 TO maxlevel DO
IF linkchain[i] <> 0 THEN
%13 write←pair(both,linkchain[i],pfaddr-i);
(* 19.*) \
%24 walkchain(linkchain[i],pfaddr-i); (* 19.*) \
checker:= pfchain
END
ELSE inlevel := false;
IF level > 1 THEN localpfptr := checker;
WHILE firstkonst <> NIL DO
WITH firstkonst↑, constptr↑ DO
BEGIN
%13 write←pair(both,addr,kaddr); (* 19.*) \
%24 walkchain (addr,kaddr); (* 19.*) \
IF (cclass IN [pset,strd]) AND double←chain THEN
%13 write←pair(both,addr-1,kaddr+1);
(* 19.*) \
%24 walkchain (addr-1,kaddr+1); (* 19.*) \
firstkonst:= nextkonst
END;
inlevel := true;
WHILE (declscalptr <> NIL) AND inlevel DO
WITH declscalptr↑ DO
IF (level = tlev) OR ((level = 1) AND (tlev = 0)) THEN
BEGIN
IF request THEN
%13 write←pair(both,vectorchain,vectoraddr);
(* 19.*) \
%24 walkchain (vectorchain,vectoraddr); (* 19.*) \
declscalptr := nextscalar
END
ELSE inlevel := false;
inlevel := true;
WHILE (last←label <> NIL) AND inlevel DO
WITH last←label↑ DO
IF scope = level THEN
BEGIN
IF goto←chain <> 0 THEN
IF label←address = 0 THEN error←with←text(214,name)
ELSE
%13 write←pair(both,goto←chain,label←address);
(* 19.*) \
%24 walkchain(goto←chain,label←address); (* 19.*) \
last←label := next
END
ELSE inlevel := false;
IF level = 1 THEN
BEGIN
j := 0;
FOR i := 1 TO jumper DO
BEGIN
IF jump←table[i] <> 0 THEN
BEGIN
%13 (* 19.*)
write←pair(both,jump←table[i],jump←address + j);
write←pair(both,jump←table[i] + 1, jump←address + j + 1);
(* 19. *) \
%24 (* 19.*)
walkchain (jump←table[i], jump←address + j);
walkchain (jump←table[i] + 1, jump←address + j + 1);
(* 19.*) \
j := j + 2
END
END
END
%13 (* 18. THE REST OF IT IS NOT USED IN PASSGO.*)
END;
write←end:
BEGIN
write←header('HIGHSEG-BREAK ');
write←block←start(no,0,item←5);
write←pair(right,0,highest←code);
write←header('LOWSEG-BREAK ');
lic := 0;
write←pair(right,0,lcmain); put←relocatable←code
END;
write←start:
IF NOT external THEN
BEGIN
write←header('START-ADDRESS ');
write←block←start(no,0,item←7);
write←pair(right,0,start←address)
END;
write←entry:
IF external THEN
BEGIN
write←block←start(no,0,item←4);
FOR i := 2 TO entries DO
write←identifier(entry←symbol,entry[i])
END;
write←name:
BEGIN
write←block←start(no,0,item←6);
write←identifier(entry←symbol,programname)
END;
write←hiseg:
BEGIN
llist←code := false;
write←block←start(no,0,item←3);
\
%1 write←pair(no,400000B,400000B) \
%3 write←pair(right,400000B,400000B) \
%13
END
END (*CASE*)
(* 18.*) \
END (*CODE←FOR←CONTROL*) ;
%13 (* 18. NOT NEEDED FOR PASSGO.*)
PROCEDURE code←for←symbols;
VAR
save←list←code: boolean;
switchflag: flagrange; checker: ctp;
BEGIN (*CODE←FOR←SYMBOLS*)
write←header('ENTRY-POINT(S) ');
write←block←start(no,0,item←2);
IF NOT external THEN
BEGIN
write←identifier(local←symbol,programname);
write←pair(right,0,start←address);
END
ELSE
BEGIN
checker := localpfptr;
WHILE checker <> NIL DO
WITH checker↑ DO
BEGIN
IF pfaddr <> 0 THEN
BEGIN
write←identifier(local←symbol,name);
write←pair(right,0,pfaddr)
END;
checker:= pfchain
END;
save←list←code := list←code; list←code := false;
checker := localpfptr;
WHILE checker <> NIL DO
WITH checker↑ DO
BEGIN
IF pfaddr <> 0 THEN
BEGIN
write←identifier(global←symbol,name);
write←pair(right,0,pfaddr)
END;
checker := pfchain
END;
list←code := save←list←code
END;
IF NOT external THEN
BEGIN
switchflag:= global←symbol;
write←header('ENTRY-SYMBOL(S) ');
END
ELSE
BEGIN
switchflag:= extern←symbol; write←header('EXTERN-SYMBOL(S) ')
END;
fileptr := sfileptr;
WHILE fileptr <> NIL DO
WITH fileptr↑, fileident↑ DO
BEGIN
IF vaddr <> 0 THEN
BEGIN
write←identifier(switchflag,name);
write←pair(right,0,vaddr)
END;
fileptr:= nextftp
END;
IF NOT external THEN
write←header('EXTERN-SYMBOL(S) ');
checker:= externpfptr;
WHILE checker <> NIL DO
WITH checker↑ DO
BEGIN
IF linkchain[0] <> 0 THEN
BEGIN
IF pflev = 0 THEN write←identifier(extern←symbol,externalname)
ELSE write←identifier(extern←symbol,name);
write←pair(right,0,linkchain[0])
END;
checker:= pfchain
END;
FOR support←index := first(support←index) TO last(support←index) DO
IF runtime←support.link[support←index] <> 0 THEN
BEGIN
write←identifier(extern←symbol,runtime←support.name[support←index]);
write←pair(right,0,runtime←support.link[support←index])
END;
IF debug THEN
BEGIN
write←identifier(extern←symbol,runtime←support.name[enterdebug]);
write←pair(right,0,debug←stop);
write←identifier(extern←symbol,runtime←support.name[initializedebug]);
write←pair(right,0,debug←initialization)
END;
IF NOT (debug OR external) THEN
BEGIN
write←identifier(extern←symbol,runtime←support.name[overflow]);
write←pair(no,0,jbapr)
END
END (*CODE←FOR←SYMBOLS*) ;
PROCEDURE code←for←libraries;
VAR
i, j, l: integer;
BEGIN (*CODE←FOR←LIBRARIES*)
write←header('LINK-LIBRARIE(S) ');
write←block←start(no,0,item←17);
FOR l := 1 TO 2 DO
BEGIN
FOR i := 1 TO library←index DO
WITH library[library←order[i]] DO
IF called THEN WITH change DO
BEGIN
FOR j := 1 TO 6 DO wsixbit[j] := ord(name[j]) - 40B;
write←identifier(sixbit←symbol,name);
write←pair(no,projnr,prognr);
FOR j := 1 TO 6 DO wsixbit[j] := ord(device[j]) - 40B;
write←identifier(sixbit←symbol,device); lic := lic + 1
END;
i := 1;
FOR language←index := fortransy DOWNTO pascalsy DO
WITH library[language←index] DO
BEGIN
called := (NOT chained AND called) OR ((language←index = pascalsy) AND NOT called);
library←order[i] := language←index; i := i + 1
END;
library←index := 2
END
END (*CODE←FOR←LIBRARIES*);
PROCEDURE coding←counters;
VAR
index: 1..100;
BEGIN (*CODING←COUNTERS*)
IF counter > 1 THEN
WITH change DO
BEGIN
write←block←start(right,lastlcmain,item←1);
FOR index := 1 TO counter - 1 DO
BEGIN
wlefthalf := line←count[index].line;
wrighthalf := line←count[index].page;
write←word(no,wkonst);
wkonst := 0;
write←word(no,wkonst);
END;
END;
END (*CODING←COUNTERS*);
(* 18.*) \
BEGIN (*WRITE←MACHINE←CODE*)
IF NOT error←flag AND NOT no←code←gen THEN
BEGIN (* 22. AVOID CODE GENERATION IN CASE OF AN ERROR.*)
%13 put←code←array := false; (* 18.*) \
space←w := 2; space←c := 0;
%13 llist←code := list←code; (* 18.*) \
CASE write←flag OF
write←fileblocks:
code←for←fileblocks;
%13 (* 14.*)
write←globals :
code←for←globals;
(* 14.*) \
write←code :
code←for←instructions;
write←debug :
code←for←debug;
%13 (* 18.*)
write←symbols :
code←for←symbols;
write←internals,
write←entry,
write←end,
write←start,
write←hiseg,
write←name :
(* 18.*) \
%24 write←internals : (* 18.*) \
code←for←control;
%13 (* 18.*)
write←library :
code←for←libraries;
write←counters:
coding←counters;
(* 18.*) \
END (*CASE*);
%13 (* 14.*)
IF list←code AND (write←flag > write←hiseg) THEN writeln(list)
(* 14.*) \
END (* IF NOT ERROR←FLAG *)
ELSE
%13
IF error←flag THEN \
BEGIN
lastbtp := NIL;
declscalptr := NIL
END;
END (*WRITE←MACHINE←CODE*);
PROCEDURE addnewcounter;
VAR
index: integer;
%24 lcntp: cntp; \
BEGIN (*ADDNEWCOUNTER*)
macro3r(350B(*AOS*),0,lcmain+1);
IF hassoslines THEN
BEGIN
linecnt := 0;
FOR index := 1 TO 5 DO
linecnt := linecnt * 10 + ord(linenr[index]) - ord('0');
END;
%13 WITH line←count[counter] DO \
%24 WITH lastcntp↑.lineinfo[counter] DO \
BEGIN
line := linecnt;
page := pagecnt;
END;
counter := counter + 1;
lcmain := lcmain + 2;
IF counter > 100 THEN
BEGIN
%13 write←machine←code(write←counters);
lastlcmain := lcmain;
\
%24
new(lcntp);
lcntp↑.next := NIL;
lastcntp↑.next := lcntp;
lastcntp := lcntp;
\
counter := 1;
END;
END (*ADDNEWCOUNTER*);
(* STATEMENT[ makereal, selector[sublowbound] *)
PROCEDURE statement(fsys,statends: setofsys);
TYPE
valuekind = (onregc,onfixedregc,truejmp,falsejmp);
VAR
lcp: ctp; j: integer;
PROCEDURE expression(fsys: setofsys; fvalue:valuekind); FORWARD;
PROCEDURE makereal(VAR fattr: attr); (*CODE TO CONVERT FROM INTEGER TO REAL*)
BEGIN (*MAKEREAL*)
IF fattr.typtr=intptr THEN
BEGIN
load(fattr);
macro3(551B(*HRRZI*),reg1,fattr.reg);
support(convertintegertoreal);
fattr.typtr := realptr
END;
IF gattr.typtr=intptr THEN makereal(gattr)
END (*MAKEREAL*);
PROCEDURE selector(fsys: setofsys; fcp: ctp);
VAR
lattr: attr; lcp: ctp; lsp: stp;
lmin,lmax,indexvalue,indexoffset: integer;
oldic: acrange;
bytes: bitrange;
PROCEDURE sublowbound; (*CODE TO ADJUST A SUBINDEX BY THE LOW BOUND OF ITS TYPE*)
var
lattr: attr;
BEGIN (*SLOWBOUND*)
IF lmin > 0 THEN macro3(275B(*SUBI*),regc,lmin)
ELSE
IF lmin < 0 THEN macro3(271B(*ADDI*),regc,-lmin);
IF runtime←check THEN
BEGIN
with lattr do
begin
typtr := intptr; kind := cst; cval.ival := lmax - lmin;
end;
generate←code(317B(*camg*),regc,lattr);
macro3(305B(*caige*),regc,0);
support(indexerror)
END
END (*SLOWBOUND*);
BEGIN (*SELECTOR*)
WITH fcp↑, gattr DO
BEGIN
typtr := idtype; kind := varbl; packfg := notpack; vclass := klass;
CASE klass OF
vars:
BEGIN
vlevel := vlev; dplmt := vaddr; indexr := 0;
IF vlev > 1 THEN vrelbyte:= no
ELSE vrelbyte:= right;
IF idtype↑.form = files THEN last←file:= fcp
ELSE last←file:= NIL;
indbit := ord(vkind)
END;
field:
WITH display[disx] DO
IF occur = crec THEN
BEGIN
vlevel := clev; packfg := packf; vrelbyte := crelbyte;
IF packfg = packk THEN
BEGIN
vbyte := fldbyte;
dplmt := cdspl
END
ELSE dplmt := cdspl+fldaddr;
indexr := cindr; indbit:=cindb
END
ELSE error(171);
func:
IF pfdeckind = standard (*STANDARD FUNCTION*) THEN error(502)
ELSE
IF pflev = 0 THEN error(502) (*EXTERNAL FUNCTION*)
ELSE
IF pfkind = formal (*FORMAL FUNCTION*) THEN error(456)
ELSE
BEGIN
vlevel := pflev+1;
vrelbyte := no;
IF NOT activated THEN error(509);
dplmt := 1; (* THE RELATIVE ADDRESS OF THE FUNCTION'S RESULT *)
indexr :=0;
indbit :=0
END
END (*CASE*)
END (*WITH*);
iferrskip(166,selectsys + fsys);
WHILE sy IN selectsys DO
BEGIN
(*[*)
IF sy = lbrack THEN
BEGIN
IF gattr.indbit = 1 THEN get←parameter←address;
oldic := gattr.indexr;
indexoffset := 0 ;
LOOP
lattr := gattr; indexvalue := 0 ;
WITH lattr DO
IF typtr <> NIL THEN
BEGIN
IF typtr↑.form <> arrays THEN
BEGIN
error(307); typtr := NIL
END;
lsp := typtr
END;
insymbol;
expression(fsys + [comma,rbrack],onregc);
IF gattr.kind<>cst THEN load(gattr)
ELSE indexvalue := gattr.cval.ival ;
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN error(403);
IF lattr.typtr <> NIL THEN WITH lattr,typtr↑ DO
BEGIN
IF comptypes(inxtype,gattr.typtr) THEN
BEGIN
IF inxtype <> NIL THEN
BEGIN
getbounds(inxtype,lmin,lmax);
IF gattr.kind = cst THEN
IF (indexvalue < lmin) OR (indexvalue > lmax) THEN error(263)
END
END
ELSE error(457);
typtr := aeltype
END
EXIT IF sy <> comma;
WITH lattr DO
IF typtr<>NIL THEN
IF gattr.kind = cst THEN dplmt := dplmt + ( indexvalue - lmin ) * typtr↑.size
ELSE
BEGIN
sublowbound;
IF typtr↑.size > 1 THEN macro3(221B(*IMULI*),regc,typtr↑.size);
IF oldic = 0 THEN oldic := regc
ELSE
IF oldic > regcmax THEN
BEGIN
macro3(270B(*ADD*),regc,oldic);
oldic := regc
END
ELSE
BEGIN
macro3(270B(*ADD*),oldic,regc) ;
regc := regc - 1
END;
indexr := oldic
END ;
gattr := lattr
END (*LOOP*);
WITH lattr DO
IF typtr <> NIL THEN
BEGIN
IF gattr.kind = cst THEN indexoffset := ( indexvalue - lmin ) * typtr↑.size
ELSE
BEGIN
IF (typtr↑.size > 1) OR runtime←check THEN sublowbound
ELSE indexoffset := -lmin;
IF typtr↑.size > 1 THEN macro3(221B(*IMULI*),regc,typtr↑.size);
indexr := regc
END ;
IF lsp↑.arraypf THEN
BEGIN
bytes := bitmax DIV lsp↑.aeltype↑.bitsize;
IF gattr.kind = cst THEN
BEGIN
bpaddr := indexoffset MOD bytes + lsp↑.arraybpaddr + 1;
indexr := oldic;
indexoffset := indexoffset DIV bytes
END
ELSE
BEGIN
increment←regc;
IF indexr=oldic THEN
BEGIN
increment←regc; indexr := 0
END;
if lmax <= maxaddr then
macro4(571B(*HRREI*),regc,indexr,indexoffset)
else
begin
macro4(200B(*move*),regc,0,indexr);
if indexoffset <> 0 then
macro3(271B(*addi*),regc,indexoffset);
end;
increment←regc;
regc := regc-1; indexoffset := 0;
macro3(231B(*IDIVI*),regc,bytes);
macro4r(200B(*MOVE*),regc-1,regc+1,lsp↑.arraybpaddr+1);
bpaddr := regc-1; indexr := regc
END;
packfg := packk
END (*ARRAYPACKFLAG*);
dplmt := dplmt + indexoffset ;
kind := varbl; vclass := vars;
IF ( oldic <> indexr ) AND ( oldic <> 0 ) THEN
BEGIN
IF oldic > regcmax THEN macro3(270B(*ADD*),indexr,oldic)
ELSE
BEGIN
macro3(270B(*ADD*),oldic,indexr);
regc := regc - 1;
indexr := oldic
END
END
END (*WITH.. IF TYPTR <> NIL*) ;
gattr := lattr ;
IF sy = rbrack THEN insymbol
ELSE error(155)
END (*IF SY = LBRACK*)
ELSE
(*.*)
IF sy = period THEN
BEGIN
WITH gattr DO
BEGIN
IF typtr <> NIL THEN
IF typtr↑.form <> records THEN
BEGIN
error(308); typtr := NIL
END;
IF indbit=1 THEN get←parameter←address;
insymbol;
IF sy = ident THEN
BEGIN
IF typtr <> NIL THEN
BEGIN
searchsection(typtr↑.fstfld,lcp);
IF lcp = NIL THEN
BEGIN
error(309); typtr := NIL
END
ELSE WITH lcp↑ DO
BEGIN
typtr := idtype; packfg := packf;
IF packfg = packk THEN
BEGIN
vclass := field; vbyte := fldbyte
END
ELSE dplmt := dplmt + fldaddr
END
END;
insymbol
END (*SY = IDENT*)
ELSE error(209)
END (*WITH GATTR*)
END (*IF SY = PERIOD*)
ELSE
(*↑*)
BEGIN
IF gattr.typtr <> NIL THEN WITH gattr,typtr↑ DO
IF form IN [pointer,files] THEN
BEGIN
IF form = pointer THEN typtr := eltype
ELSE typtr := filtype;
IF typtr <> NIL THEN
BEGIN
loadnoptr := false;
load(gattr); loadnoptr := true;
(* 12. CHECK FOR ZERO OR NIL POINTER *)
IF runtime←check AND (form = pointer) THEN
BEGIN
macro3(302B(*CAIE*),reg,0);
macro3(306B(*CAIN*),reg,377777B);
support(badpointer);
END;
%13 (* 14. EXTERNAL SUPPRESSED FROM PASSGO *)
WITH fcp↑ DO
IF (idtype↑.form = files) AND (vlev = 0) AND external THEN
BEGIN
vaddr:= ic-1; code←reference↑[cix] := externref
END;
(* 14.*) \
indexr := reg; dplmt := 0; indbit:=0; packfg := notpack; kind := varbl;
vrelbyte:= no; vclass := vars
END
END
ELSE error(407);
insymbol
END (*↑*);
iferrskip(166,fsys + selectsys)
END (*WHILE*);
WITH gattr DO
IF typtr<>NIL THEN
IF typtr↑.size = 2 THEN
BEGIN
IF indbit = 1 THEN get←parameter←address;
IF (indexr>regin) AND (indexr<=regcmax) THEN increment←regc
END
END (*SELECTOR*) ;
(* profuncall[getfilename,getputresetrewrite,readreadln,breakcall,writewriteln,messagecall*)
PROCEDURE profuncall(fsys: setofsys; fcp: ctp);
LABEL
666;
VAR
lkey: integer;
lclass: idclass;
lsupport: supports;
tty←message, noload, lfollowerror, no←right←parent, buffer←variable : boolean;
PROCEDURE getfilename(default←name:alfa; followsys: setofsys);
(*PARSES THE FIRST PARAMETER IN CALLS TO FILE-RELATED
PROCEDURES AND FUNCTIONS, OR DEFAULTS IT TO THE
APPROPRIATE STANDARD FILE*)
VAR
lcp : ctp ; lvlev: levrange; default,default←tty : boolean ;
lsy: symbol; lid: alfa;
BEGIN (*GETFILENAME*)
default := true ; default←tty := false; no←right←parent := true;
buffer←variable := false;
IF sy = lparent THEN
BEGIN
no←right←parent := false;
insymbol ;
IF sy = ident THEN
BEGIN
searchid([konst,vars,field,proc,func],lcp);
IF lcp <> NIL THEN
WITH lcp↑,idtype↑ DO
IF idtype <> NIL THEN
BEGIN
IF form = files THEN
BEGIN
IF arrow IN followsys THEN insymbol;
IF sy <> arrow THEN
BEGIN
default := false;
IF
(((lkey IN [2,4,7,8,10,11,17,19,28]) AND (lclass = proc)) OR
((lkey = 11) AND (lclass = func))) AND
(file←form <> text←file) THEN error(366)
END
ELSE buffer←variable := true
END;
IF klass = vars THEN lvlev := vlev
ELSE lvlev := 1
END;
IF (lvlev = 0) AND
(id = 'TTY ') AND
((default←name = 'OUTPUT ') OR (default←name = 'TTYOUTPUT ')) AND
NOT buffer←variable THEN
BEGIN
default := true; default←tty := true;
default←name := 'TTYOUTPUT '
END
END (*SY = IDENT*)
END (*SY = LPARENT*);
IF no←right←parent
AND (sy IN (facbegsys + [addop])) AND NOT ( (lclass=func) AND (lkey IN [10,11]) ) THEN error(156);
ttyread := (NOT default AND (id = 'TTY ')) OR
(default AND (default←name = 'TTY ')) OR ttyread;
outputwrite := outputwrite OR (NOT default AND (id = 'OUTPUT ')) OR
(default AND (default←name = 'OUTPUT ')); (* 13. REWRITE OUTPUT ONLY IF NEEDED.*)
IF default THEN
BEGIN
lid := id; id := default←name;
searchid([vars],lcp);
IF lcp↑.idtype↑.form <> files THEN searchsection(display[0].fname,lcp);
id := lid
END ;
lsy := sy; sy := comma; lfollowerror := followerror;
selector(fsys + [comma,rparent],lcp) ;
sy := lsy; followerror := lfollowerror;
IF noload THEN
WITH gattr DO
BEGIN
IF (indbit <> 0) %13 OR ((lcp↑.vlev = 0) AND external) (* 14.*) \ THEN load←address;
CASE lkey OF
10:
dplmt := dplmt + fileof; (*EOF*)
11:
dplmt := dplmt + fileol; (*EOLN*)
17:
dplmt := dplmt + fillnr (*GETLINENR*)
END
END
ELSE load←address;
IF buffer←variable THEN
BEGIN
searchid([vars],lcp);
selector(fsys + (followsys-[arrow]),lcp)
END;
IF NOT default OR default←tty THEN
BEGIN
IF NOT (arrow IN followsys) THEN insymbol;
IF NOT (sy IN followsys-[arrow]) THEN
error(458)
ELSE
IF sy = comma THEN insymbol
END
END (*GETFILENAME*) ;
PROCEDURE variable(fsys: setofsys);
VAR
lcp: ctp;
BEGIN (*VARIABLE*)
IF sy = ident THEN
BEGIN
searchid([vars,field],lcp); insymbol
END
ELSE
BEGIN
error(209); lcp := uvarptr
END;
selector(fsys,lcp)
END (*VARIABLE*) ;
PROCEDURE getputresetrewrite;
VAR
default : ARRAY [1..4] OF boolean;
i : integer;
lattr: attr;
PROCEDURE getstringaddress(length: integer) ;
BEGIN (*GETSTRINGADDRESS*)
IF sy <> rparent THEN
BEGIN
expression(fsys + [comma],onfixedregc);
WITH gattr DO
IF string(typtr) THEN
WITH typtr↑ DO
IF arraypf AND (size=2) AND (inxtype↑.vmax.ival-inxtype↑.vmin.ival+1 = length) THEN
BEGIN
default[i] := false; load←address
END
ELSE error(458)
ELSE error(458)
END
END (*GETSTRINGADDRESS*);
BEGIN (*GETPUTRESETREWRITE*)
CASE lkey OF
1,2 :
getfilename('INPUT ',[rparent]); (*GET, GETLN*)
3,4 :
getfilename('OUTPUT ',[rparent]); (*PUT, PUTLN*)
5 :
getfilename('INPUT ',[comma,rparent]); (*RESET*)
6 :
getfilename('OUTPUT ',[comma,rparent]) (*REWRITE*)
END;
IF lkey IN [5,6] THEN (*RESET, REWRITE*)
BEGIN
FOR i := 1 TO 4 DO default[i] := true;
i := 1;
getstringaddress(9) (* OF FILENAME *) ;
WHILE (i<3) AND NOT default[1] AND (sy=comma) DO (*PROTECTION, PPN, DEVICE (?)*)
BEGIN
i := i + 1;
insymbol; expression(fsys + [comma],onfixedregc);
IF gattr.typtr <> NIL THEN
IF comptypes(gattr.typtr,intptr) THEN
BEGIN
load(gattr); default[i] := false
END
ELSE error(458)
END;
IF NOT default[3] THEN (*DEVICE*)
BEGIN
i := i+1;
IF sy = comma THEN insymbol;
getstringaddress(6) (* OF DEVICE NAME *)
END;
FOR i := 1 TO 4 DO
IF default[i] THEN
BEGIN
increment←regc;
macro2(400B(*SETZ*),regc)
END
END (*IF LKEY IN [5,6]*) (*RESET, REWRITE*);
CASE lkey OF
1: (*GET*)
BEGIN
lsupport := getfile;
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.file←form = text←file THEN lsupport := getcharacter
END;
2: (*GETLN*)
IF comptypes(gattr.typtr,textptr) THEN lsupport := getline
ELSE error(366) ;
3: (*PUT*)
lsupport := putfile ;
4: (*PUTLN*)
IF comptypes(gattr.typtr,textptr) THEN lsupport := putline
ELSE error(366) ;
5: (*RESET*)
lsupport := resetfile ;
6: (*REWRITE*)
lsupport := rewritefile
END ;
support(lsupport);
IF (lkey = 1) AND (gattr.typtr <> NIL) AND runtime←check THEN
IF gattr.typtr↑.filtype <> NIL THEN (*BOUNDARY CHECK FOR FILES OF SUBRANGE*)
WITH gattr.typtr↑.filtype↑ DO
IF (form = subrange) AND (gattr.typtr↑.file←form <> text←file) THEN
BEGIN
increment←regc; macro4(200B(*MOVE*),regc,regc-1,filcmp);
lattr.kind := cst; lattr.typtr := rangetype;
lattr.cval := vmax; generate←code(317B(*CAMG*),regc,lattr);
lattr.cval := vmin; generate←code(315B(*CAMGE*),regc,lattr);
support(inputerror)
END;
END (*GETPUTRESETREWRITE*);
PROCEDURE profuncall←support;
BEGIN (*profuncall←SUPPORT*)
IF (lsupport IN [readirange..wrtdset,readpseudostring..writedefpseudostring])
AND ((sy = comma) OR (lkey IN [8,11])) THEN (* 25.*)
BEGIN
IF NOT reg2←saved THEN
BEGIN
reg2←saved := true;
reg2←location := lc;
lc := lc + 1;
IF lc > lcmax THEN lcmax := lc
END;
macro4(202B(*MOVEM*),regc,basis,reg2←location);
support(lsupport);
macro4(200B(*MOVE*),regc,basis,reg2←location)
END
ELSE support(lsupport)
END (*profuncall←SUPPORT*);
PROCEDURE readreadln; (*READ A LIST OF PARAMETERS FROM A TEXT FILE*)
VAR
boundclass: cstclass;
lattr: attr;
baseform: structform;
%9 savregc: integer; (* 16.*) \
BEGIN (*READREADLN*)
getfilename('INPUT ',[arrow,rparent,comma]);
IF (lkey = 7) OR ((lkey = 8) AND (sy = ident)) OR buffer←variable THEN
LOOP
IF NOT buffer←variable THEN
BEGIN
%9 savregc := regc; (* 16.*) \
variable(fsys + [comma]);
%9 (* 16. FIX THE MOD BUG (KO)*)
IF (regc > savregc+1) AND (gattr.indexr > savregc) THEN
BEGIN
macro3 (200B(*MOVE*),regc-1,regc);
regc := regc - 1;
gattr.indexr := gattr.indexr - 1;
END;
(* 16. END OF FIX.*) \
load←address
END;
lsupport := readinteger;
buffer←variable := false;
WITH gattr DO
IF typtr <> NIL THEN
IF typtr↑.form IN [scalar,subrange,power] THEN
BEGIN
IF typtr = charptr THEN typtr := asciiptr;
baseform := typtr↑.form;
IF typtr↑.form = power THEN
BEGIN
typtr := typtr↑.elset;
IF comptypes(typtr,asciiptr) THEN
BEGIN
macro3(551B(*HRRZI*),regc+1,offset);
macro3(551B(*HRRZI*),regc+2,basemax + offset)
END
END;
IF typtr <> NIL THEN
IF typtr↑.form = subrange THEN
BEGIN
IF comptypes(realptr,typtr↑.rangetype) THEN boundclass := reel
ELSE boundclass := int;
lattr.kind := cst;
lattr.cval := typtr↑.vmin; macro2(200B(*MOVE*),regc+1); deposit←constant(boundclass,lattr);
lattr.cval := typtr↑.vmax; macro2(200B(*MOVE*),regc+2); deposit←constant(boundclass,lattr);
typtr := typtr↑.rangetype
END
ELSE
IF typtr↑.scalkind = declared THEN
BEGIN
macro3(551B(*HRRZI*),regc+2,typtr↑.dimension);
macro2(400B(*SETZ*),regc+1)
END;
IF typtr <> NIL THEN
IF typtr↑.scalkind = declared THEN
WITH typtr↑ DO
BEGIN
request := true; macro3r(551B(*HRRZI*),regc+3,vectorchain);
code←reference↑[cix] := constref; vectorchain := ic-1;
lsupport := read←support[declaredform,baseform]
END
ELSE
BEGIN
IF typtr = intptr THEN lsupport := read←support[integerform,baseform]
ELSE
IF comptypes(typtr,asciiptr) THEN lsupport := read←support[charform,baseform]
ELSE
IF typtr = realptr THEN lsupport := read←support[realform,baseform]
ELSE error(458)
END
END
ELSE
IF string(typtr) THEN
BEGIN
IF typtr↑.arraypf THEN lsupport := readpackedstring
ELSE lsupport := readstring;
WITH typtr↑.inxtype↑ DO macro3(551B(*HRRZI*),regc+1,vmax.ival-vmin.ival+1)
END
ELSE
(* 25. ACCEPT TYPE 'STRING' *)
IF typtr = sstringptr THEN
IF stringpack THEN
lsupport := readpseudostring
ELSE
error (321)
ELSE
(* 25.*)
error(169);
regc := regin + 1;
profuncall←support
EXIT IF sy <> comma;
insymbol
END;
IF lkey = 8 THEN support(getline)
END (*READREADLN*) ;
PROCEDURE breakcall; (*SEND THE OUTPUT BUFFER TO THE FILE*)
BEGIN (*BREAKCALL*)
getfilename('TTYOUTPUT ',[rparent]);
support(putbuffer)
END (*BREAKCALL*);
PROCEDURE writewriteln; (*WRITE INTO A TEXT FILE A LIST OF PARAMETERS*)
VAR
llsp, lsp: stp;
default, realformat, declared←or←set: boolean;
%9 savregc, (* 16.*) \
lsize, lmin, lmax: integer;
BEGIN (*WRITEWRITELN*)
IF NOT tty←message THEN getfilename('OUTPUT ',[rparent,comma,arrow,colon]);
IF (lkey = 10) OR ((lkey = 11) AND (sy IN facbegsys + [addop])) OR buffer←variable THEN
LOOP
IF NOT buffer←variable THEN
BEGIN
%9 savregc := regc; (* 16. IDIV USES TWO REGISTERS.*) \
expression(fsys + [comma,colon],onfixedregc);
END;
lsp := gattr.typtr;
lsupport := writeinteger;
IF lsp <> NIL THEN
WITH lsp↑ DO
IF form <= power THEN
BEGIN
%9 (* 16. FIX THE MOD BUG.*)
IF (regc > savregc + 1) AND (gattr.indexr >= regc) THEN
BEGIN
macro3 (200B(*MOVE*),regc-1, regc);
regc := regc-1;
gattr.indexr := gattr.indexr - 1;
END;
(* 16. END OF FIX.*) \
load(gattr);
declared←or←set := (form = power) OR ((form = scalar) AND (scalkind = declared) AND NOT (lsp = boolptr))
END
ELSE
BEGIN
IF NOT buffer←variable THEN load←address;
declared←or←set := false
END;
buffer←variable := false;
IF sy = colon THEN (*FIELD WIDTH*)
BEGIN
insymbol;
expression(fsys + [comma,colon],onfixedregc);
IF gattr.typtr <> NIL THEN
BEGIN
IF gattr.typtr <> intptr THEN error(458);
IF gattr.kind <> expr THEN
BEGIN
generate←code( 200B (*MOVE*) , regin+3 , gattr ) ;
regc := gattr.reg ;
END ;
END ;
default := false
END
ELSE
BEGIN
default := true;
increment←regc (*RESERVE REGISTER FOR DEFAULT VALUE*)
END ;
IF sy = colon THEN (*SECOND FORMAT MODIFIER*)
BEGIN
insymbol;
IF comptypes(lsp,intptr) THEN
BEGIN
IF (sy = ident) AND ((id='O ') OR (id='H ')) THEN
IF id = 'O ' THEN lsupport := writeoctal
ELSE lsupport := writehexadecimal
ELSE error(262);
insymbol
END
ELSE
BEGIN
expression(fsys + [comma],onfixedregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr <> intptr THEN error(458);
IF lsp <> realptr THEN error(258);
load(gattr);
realformat := false
END
END
ELSE realformat := true;
IF lsp <> intptr THEN
BEGIN
IF comptypes(lsp,asciiptr) THEN lsupport := writecharacter
ELSE
IF lsp = realptr THEN
IF realformat THEN lsupport := writedef1real
ELSE lsupport := writereal
ELSE
IF lsp = boolptr THEN lsupport := writeboolean
ELSE
WITH lsp↑ DO
IF string(lsp) THEN
BEGIN
IF inxtype <> NIL THEN
BEGIN
getbounds(inxtype,lmin,lmax);
lsize := lmax-lmin+1
END
ELSE lsize := 0;
macro3(551B(*HRRZI*),regin+4,lsize);
IF arraypf THEN lsupport := writepackedstring
ELSE lsupport := writestring
END
ELSE
IF (lsp <> NIL) AND declared←or←set THEN
BEGIN
IF form = power THEN
BEGIN
IF elset <> NIL THEN
IF elset↑.form = subrange THEN llsp := elset↑.rangetype
ELSE llsp := elset
END
ELSE llsp := lsp;
IF llsp <> NIL THEN
IF llsp↑.scalkind = declared THEN
WITH llsp↑ DO
BEGIN
IF default THEN macro3(515B(*HRLZI*),regc,dimension)
ELSE macro3(505B(*HRLI*),regc,dimension);
macro3r(551B(*HRRZI*),regc+1,vectorchain);
vectorchain := ic-1; request := true;
code←reference↑[cix] := constref; lsupport := write←support[declaredform,lsp↑.form]
END
ELSE
BEGIN
IF default THEN macro2(400B(*SETZ*),regc);
IF llsp = intptr THEN lsupport := write←support[integerform,form]
ELSE
IF comptypes(llsp,asciiptr) THEN lsupport := write←support[charform,form]
ELSE error(458)
END
END
ELSE
(* 25. ACCEPT TYPE 'STRING'*)
IF lsp = sstringptr THEN
IF stringpack THEN
lsupport := writepseudostring
ELSE
error(321)
ELSE
(* 25.*)
error(458)
END;
IF default AND NOT declared←or←set THEN lsupport := succ( lsupport );
regc :=regin + 1;
profuncall←support
EXIT IF sy <> comma;
insymbol
END (* LOOP *);
IF lkey = 11 THEN support(putline)
END (*WRITEWRITELN*) ;
PROCEDURE messagecall;
(* MESSAGE(<ARGUMENT LIST>)
IS EQUIVALENT TO
WRITELN(TTY);
WRITELN(TTY,<ARGUMENT LIST>);
BREAK(TTY); *)
BEGIN (*MESSAGECALL*)
increment←regc;
macro3r(551B(*HRRZI*),regc,stdfileptr[4]↑.vaddr);
%13 (* 14.*)
IF external THEN stdfileptr[4]↑.vaddr := ic - 1;
(* 14.*) \
support(putline);
lkey := 11; tty←message := true;
writewriteln;
tty←message := false;
support(putbuffer)
END (*MESSAGECALL*);
(* packunpack, newdispose, firstlast, lowerupperbound *)
PROCEDURE packunpack;
(******************************************************************************
*
* PACK(A,I,Z<,J<,L>>) EXECUTES: FOR K := 0 TO L1-1 DO Z[J1+K] := A[I+K]
*
* UNPACK(Z,A,I<,J<,L>>) EXECUTES: FOR K := 0 TO L1-1 DO A[I+K] := Z[J1+K]
*
* A IS AN ARRAY OF A SCALAR-TYPE,
* Z IS A PACKED ARRAY OF THIS TYPE (SO THE BITSIZE MUST BE <= 18),
* I IS THE ABSOLUTE START-INDEX IN A,
* J IS THE ABSOLUTE START-INDEX IN Z,
* L IS THE NUMBER OF ELEMENTS TO BE PACKED/UNPACKED,
* J1 IS J (DEFAULT: LOWERBOUND(Z)),
* L1 IS L (DEFAULT: MIN(UPPERBOUND(Z)-J1,UPPERBOUND(A)-I)+1),
* K IS NOT DENOTED ELSEWHERE IN THE PROGRAM.
*
******************************************************************************)
VAR
a,i,z,j,l: attr; lregc: acrange;
length, astart, zstart, amax, amin, zmax, zmin, packfactor: integer;
default←length: boolean;
PROCEDURE adjust( VAR fattr: attr; fbound: integer);
BEGIN (*ADJUST*)
load(fattr);
IF fbound < 0 THEN macro3(271B(*ADDI*),fattr.reg,-fbound)
ELSE
IF fbound > 0 THEN macro3(275B(*SUBI*),fattr.reg,fbound);
IF runtime←check THEN
BEGIN
macro2(305B(*CAIGE*),fattr.reg);
support(indexerror)
END
END (*ADJUST*);
PROCEDURE getoffset( VAR fattr: attr; fsys: setofsys; comptyptr: stp);
BEGIN (*GETOFFSET*)
expression(fsys,onregc); fattr := gattr;
IF NOT error←flag THEN
WITH fattr DO
IF typtr <> NIL THEN
IF NOT comptypes(typtr,comptyptr) THEN error(458);
IF (sy=comma) AND (comma IN fsys) THEN insymbol
ELSE
IF (sy <> rparent) OR NOT (rparent IN fsys) THEN error(458)
END (*GETOFFSET*);
PROCEDURE getvar( VAR fattr: attr; fsys: setofsys; comptyptr: stp);
BEGIN (*GETVAR*)
variable(fsys); load←address; fattr := gattr;
IF NOT error←flag THEN
WITH fattr DO
IF typtr <> NIL THEN
WITH typtr↑ DO
IF form = arrays THEN
BEGIN
IF comptyptr = NIL THEN
IF lkey = 12 THEN
BEGIN
IF arraypf THEN error(458)
END
ELSE
BEGIN
IF NOT arraypf THEN error(458)
END
ELSE
IF NOT ((arraypf <> comptyptr↑.arraypf) AND
comptypes(aeltype,comptyptr↑.aeltype) AND
comptypes(inxtype,comptyptr↑.inxtype)) THEN error(458);
kind := expr;
IF arraypf THEN
BEGIN
reg := reg1; regc := regc-1;
code←array↑.instruction[cix].ac := reg1
END
ELSE reg := indexr
END
ELSE error(458);
IF (sy = comma) AND (comma IN fsys) THEN insymbol
ELSE
IF (sy <> rparent) OR NOT (rparent IN fsys) THEN error(458)
END (*GETVAR*);
BEGIN (* PACKUNPACK *)
lregc := regc; default←length := true;
IF lkey = 12 THEN
BEGIN
getvar(a,[comma],NIL);
IF a.typtr <> NIL THEN getoffset(i,[comma],a.typtr↑.inxtype)
ELSE getoffset(i,[comma],NIL);
getvar(z,[comma,rparent],a.typtr)
END
ELSE
BEGIN
getvar(z,[comma],NIL);
getvar(a,[comma],z.typtr);
IF a.typtr <> NIL THEN getoffset(i,[comma,rparent],a.typtr↑.inxtype)
ELSE getoffset(i,[comma,rparent],NIL)
END;
IF NOT error←flag THEN
BEGIN
getbounds(a.typtr↑.inxtype,amin,amax); amax := amax-amin;
getbounds(z.typtr↑.inxtype,zmin,zmax); zmax := zmax-zmin;
END;
WITH j DO
BEGIN
kind := cst; cval.ival := zmin
END;
WITH l DO
BEGIN
kind := cst; cval.ival := 0
END;
IF sy <> rparent THEN
BEGIN
IF z.typtr <> NIL THEN getoffset(j,[comma,rparent],z.typtr↑.inxtype)
ELSE getoffset(j,[comma,rparent],NIL);
IF sy <> rparent THEN
BEGIN
default←length := false;
getoffset(l,[rparent],intptr)
END
END;
IF NOT error←flag THEN
BEGIN
astart := 0; packfactor := bitmax DIV z.typtr↑.aeltype↑.bitsize;
IF (i.kind = cst) AND (j.kind = cst) AND (l.kind = cst) THEN
BEGIN
astart := i.cval.ival - amin;
zstart := j.cval.ival - zmin;
IF (astart >= 0) AND (zstart >= 0) THEN
BEGIN
length := min(zmax-zstart, amax-astart) + 1;
IF length >= 0 THEN
BEGIN
IF NOT default←length THEN
IF (l.cval.ival >= 0) AND (l.cval.ival <= length) THEN length := l.cval.ival
ELSE error(263);
macro3(505B(*HRLI*),a.reg,-length);
IF (zstart DIV packfactor) <> 0 THEN
macro3(271B(*ADDI*),z.reg,zstart DIV packfactor);
macro3r(200B(*MOVE*),regc+1,z.typtr↑.arraybpaddr+(zstart MOD packfactor))
END
ELSE error(263)
END
ELSE error(263)
END
ELSE (* KIND <> CST *)
BEGIN
adjust(i,amin);
macro3(270B(*ADD*),a.reg,i.reg);
adjust(j,zmin);
IF runtime←check OR default←length THEN
BEGIN
macro3(275B(*SUBI*),i.reg,amax);
macro3(200B(*MOVE*),regc+1,j.reg);
macro3(275B(*SUBI*),regc+1,zmax);
macro3(315B(*CAMGE*),i.reg,regc+1);
macro3(200B(*MOVE*),i.reg,regc+1);
IF runtime←check THEN
BEGIN
macro2(303B(*CAILE*),i.reg);
support(indexerror)
END;
IF default←length THEN macro4(505B(*HRLI*),a.reg,i.reg,-1)
END;
IF NOT default←length THEN
IF runtime←check OR (l.kind <> cst) THEN
BEGIN
generate←code(210B(*MOVN*),regc+1,l);
IF runtime←check THEN
BEGIN
macro2(307B(*CAIG*),l.reg);
macro3(315B(*CAMGE*),l.reg,i.reg);
support(indexerror)
END;
macro3(504B(*HRL*),a.reg,l.reg)
END
ELSE macro3(505B(*HRLI*),a.reg,-l.cval.ival);
macro3(231B(*IDIVI*),j.reg,packfactor);
macro3(270B(*ADD*),z.reg,j.reg);
macro4r(200B(*MOVE*),regc+1,j.reg+1,z.typtr↑.arraybpaddr)
END;
IF lkey = 12 THEN
BEGIN
macro4(200B(*MOVE*),reg0,a.reg,astart);
macro3(136B(*IDPB*),reg0,regc+1)
END
ELSE
BEGIN
macro3(134B(*ILDB*),reg0,regc+1);
macro4(202B(*MOVEM*),reg0,a.reg,astart)
END;
macro3r(253B(*AOBJN*),a.reg,ic-2)
END (* IF NOT ERROR←FLAG *)
END (* PACKUNPACK *);
PROCEDURE newdispose;
(* "NEW" ALLOCATES STORAGE FOR A DYNAMIC VARIABLE
(F.E. A RECORD VARIANT) IN THE HEAP.
"DISPOSE" DE-ALLOCATES THE STORAGE OCCUPIED BY
SUCH A VARIABLE AND IN THIS IMPLEMENTATION IT
DE-ALLOCATES THE STORAGE OF ALL VARIABLES ALLOCATED
LATER THAN THE SPECIFIED ONE TOO.
THIS IS DUE TO THE STACK-LIKE HEAP MANAGEMENT
WITH ONLY "NEWREG" POINTING TO THE LAST ALLOCATED
WORD OF CORE*)
LABEL
777;
VAR
lsp,lsp1: stp; varts,lmin,lmax: integer;
lnlk : nlk;
lengthreg: acrange;
lsize,lsz: addrrange; lval: valu;
lattrc, lattr: attr; i,tagfc: integer;
tagfsav: ARRAY[0..tagfmax] OF RECORD
tagfval: integer;
tagtype: tagfwithid..tagfwithoutid;
CASE tpackkind: packkind OF
notpack,
hwordl,
hwordr: (tagfaddr: addrrange);
packk: (tagfbyte: bpointer)
END;
BEGIN (*NEWDISPOSE*)
increment←regc; variable(fsys + [comma,colon]);
IF lkey = 24 (*DISPOSE*) THEN
BEGIN
generate←code(200B(*MOVE*),reg0,gattr);
lengthreg := reg1
END
ELSE lengthreg := regin + 1;
lsp := NIL; varts := 0; lsize := 0; tagfc := -1;
lattr := gattr;
IF gattr.typtr <> NIL THEN WITH gattr.typtr↑ DO
IF form = pointer THEN
BEGIN
IF eltype <> NIL THEN
BEGIN
lsize := eltype↑.size;
IF eltype↑.form = records THEN lsp := eltype↑.recvar
ELSE
IF eltype↑.form = arrays THEN lsp := eltype
END
END
ELSE error(458);
WHILE sy = comma DO
BEGIN
insymbol; constant(fsys + [comma,colon],lsp1,lval);
varts := varts + 1;
IF lsp <> NIL THEN
IF NOT (string(lsp) OR (lsp1 = realptr)) THEN
BEGIN
tagfc := tagfc + 1;
IF tagfc <= tagfmax THEN
IF lsp↑.form = tagfwithid THEN
BEGIN
IF lsp↑.tagfieldp <> NIL THEN
IF comptypes(lsp↑.tagfieldp↑.idtype,lsp1) THEN
WITH tagfsav[tagfc], lsp↑.tagfieldp↑ DO
BEGIN
tagfval := lval.ival;
tagtype := tagfwithid; tpackkind := packf;
IF tpackkind = packk THEN tagfbyte := fldbyte
ELSE tagfaddr := fldaddr
END
ELSE error(458)
END
ELSE
IF lsp↑.form = tagfwithoutid THEN
IF comptypes(lsp↑.tagfieldtype,lsp1) THEN tagfsav[tagfc].tagtype := tagfwithoutid
ELSE error(458)
ELSE error(358)
ELSE
BEGIN
error(409); tagfc := tagfmax
END;
lsp1 := lsp↑.fstvar;
WHILE lsp1 <> NIL DO
WITH lsp1↑ DO
IF varval.ival = lval.ival THEN
BEGIN
lsize := size; lsp := subvar; GOTO 777
END
ELSE lsp1 := nxtvar;
lsize := lsp↑.size; lsp := NIL;
777:
END
ELSE error(460)
ELSE error(408)
END (*WHILE*) ;
IF sy = colon THEN
BEGIN
insymbol;
expression(fsys,onregc);
IF lsp = NIL THEN error(408)
ELSE
IF lsp↑.form <> arrays THEN error(259)
ELSE
BEGIN
IF NOT comptypes(gattr.typtr,lsp↑.inxtype) THEN error(458);
lsz := 1; lmin := 1;
IF lsp↑.inxtype <> NIL THEN getbounds(lsp↑.inxtype,lmin,lmax);
IF lsp↑.aeltype <> NIL THEN lsz := lsp↑.aeltype↑.size;
load(gattr);
IF lsz <> 1 THEN macro3(221B(*IMULI*),regc,lsz);
IF lsp↑.arraypf THEN
BEGIN
macro3(271B(*ADDI*),regc,lsp↑.aeltype↑.bitsize-1);
increment←regc; regc := regc - 1;
(*FOR TESTING BECAUSE IDIV WORKS ON AC+1 TOO*)
macro3(231B(*IDIVI*),regc,bitmax DIV lsp↑.aeltype↑.bitsize);
lsz := lsize - lsp↑.size + 1
END
ELSE lsz := lsize - lsp↑.size - lsz*(lmin - 1);
macro4(551B(*HRRZI*),lengthreg,regc,lsz)
END
END
ELSE macro3(551B(*HRRZI*),lengthreg,lsize);
IF lkey = 14 THEN
BEGIN
IF debug←switch THEN
BEGIN
macro3(540B(* HRR *),reg0,newreg);
IF lattr.typtr <> NIL THEN
IF lattr.typtr↑.eltype <> NIL THEN
BEGIN
macro3r(505B(* HRLI *), reg0,0);
code←reference↑[cix] := debugref;
new(lnlk);
WITH lnlk↑ DO
BEGIN
refadr := ic - 1;
reftype := lattr.typtr↑.eltype;
next := globnewlink;
globnewlink := lnlk;
END;
END
END;
support(allocate);
IF debug←switch THEN
BEGIN
macro3(360B(*SOJ*),newreg,0);
macro4(202B(*MOVEM*),reg0,newreg,0)
END;
regc := regin+1;
FOR i := 0 TO tagfc DO
WITH tagfsav[i] DO
BEGIN
IF tagtype = tagfwithid THEN
BEGIN
macro3(551B(*HRRZI*),reg0,tagfval);
CASE tpackkind OF
notpack:
macro4(202B(*MOVEM*),reg0,regc,tagfaddr);
hwordr:
macro4(542B(*HRRM*),reg0,regc,tagfaddr);
hwordl:
macro4(506B(*HRLM*),reg0,regc,tagfaddr);
packk :
BEGIN
WITH lattrc, cval, byte DO
BEGIN
kind := cst;
cval.byte := tagfbyte;
ireg := regc
END;
macro2(137B(*DPB*),reg0); deposit←constant(bptr,lattrc)
END
END(*CASE*)
END
END;
store(regc,lattr)
END
ELSE support(free)
END (*NEWDISPOSE*) ;
PROCEDURE firstlast;
(* RETURN LOWER- OR UPPERBOUND OF "STANDARD SCALARS",
"DECLARED SCALARS" AND THEIR "SUBRANGES"*)
VAR
lmin, lmax: integer;
BEGIN (*FIRSTLAST*)
variable(fsys + [rparent]);
IF gattr.typtr <> NIL THEN
WITH gattr DO
IF NOT comptypes(realptr,typtr) THEN
BEGIN
getbounds(typtr,lmin,lmax);
kind := cst;
IF lkey = 21 THEN cval.ival := lmin
ELSE cval.ival := lmax;
IF typtr↑.form = subrange THEN typtr := typtr↑.rangetype
END
ELSE error(459)
END (*FIRSTLAST*);
PROCEDURE lowerupperbound;
(* RETURN LOWER- OR UPPERBOUND OF
ARRAY INDEX TYPE*)
VAR
lmin, lmax: integer;
BEGIN (*LOWERUPPERBOUND*)
variable(fsys + [rparent]);
IF gattr.typtr <> NIL THEN
WITH gattr DO
IF (typtr↑.form = arrays) AND (typtr↑.inxtype <> NIL) THEN
BEGIN
getbounds(typtr↑.inxtype,lmin,lmax);
kind := cst;
IF lkey = 15 THEN cval.ival := lmin
ELSE cval.ival := lmax;
IF typtr↑.inxtype↑.form = subrange THEN typtr := typtr↑.inxtype↑.rangetype
ELSE typtr := typtr↑.inxtype
END
ELSE error(459)
END (*LOWERUPPERBOUND*);
(*minmax,getlinenrcall,pagecall,datecall,timecall,clockcall,cardcall*)
PROCEDURE minmax;
(* THIS PROCEDURE GENERATES CODE FOR THE MIN/MAX FUNCTION.
THE MAXIMUM NUMBER OF SCALAR-TYPE EXPRESSIONS -EXCEPT REAL-
IS 72 *)
CONST
topp←offset = 2;
max←expr = 72;
VAR
i, j: integer;
lregc: acrange;
insert←size: coderange;
linstr: instrange;
first←expression, conversion: boolean;
selector: scalarform;
argument: PACKED ARRAY[1..max←expr] OF scalarform;
BEGIN (*MINMAX*)
first←expression := true;
conversion := false;
i := 1;
lregc := regc;
macro4(307B(*CAIG*),newreg,topp,0); insert←size := cix;
support(stackoverflow);
LOOP
expression(fsys + [comma,rparent], onfixedregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN error(458)
ELSE
WITH gattr DO
BEGIN
load(gattr);
IF typtr = intptr THEN argument[i] := integerform
ELSE
IF typtr = realptr THEN argument[i] := realform
ELSE
IF comptypes(typtr,asciiptr) THEN argument[i] := charform
ELSE
IF (typtr↑.scalkind = declared) AND (typtr <> boolptr) THEN argument[i] := declaredform
ELSE error(458);
macro4(202B(*MOVEM*),reg,topp,topp←offset + i);
IF first←expression THEN
BEGIN
first←expression := false; selector := argument[i]
END
ELSE
IF selector <> argument[i] THEN
IF [selector,argument[i]] <= [integerform,realform] THEN
BEGIN
conversion := true; selector := realform
END
ELSE error(458)
END
EXIT IF sy <> comma;
i := i + 1;
IF i > max←expr THEN
BEGIN
error(458); i := 1
END;
insymbol;
regc := lregc
END;
if i <= 1 then (*one only parameter*)
error(554)
else
IF NOT error←flag THEN
BEGIN
insert←address(no, insert←size, topp←offset + i);
IF conversion THEN
FOR j := 1 TO i DO
IF argument[j] = integerform THEN
BEGIN
macro4(551B(*HRRZI*),reg1,topp,topp←offset + j);
support(convertintegertoreal)
END;
increment←regc;
macro4(541B(*HRRI*),regc,topp,topp←offset + 2);
macro3(505B(*HRLI*),regc,-(i - 1));
macro4(200B(*MOVE*),gattr.reg,topp,topp←offset + 1);
IF lkey = 20 THEN linstr := 315B(*CAMGE*)
ELSE linstr := 313B(*CAMLE*);
macro4(linstr,gattr.reg,regc,0);
macro4(200B(*MOVE*),gattr.reg,regc,0);
macro3(253B(*AOBJN*),regc,ic - 2);
IF conversion THEN gattr.typtr := realptr
END
END (*MINMAX*);
PROCEDURE getlinenrcall; (*ASSIGN THE CURRENT LINE NUMBER FROM A TEXT FILE
TO A PACKC5 PARAMETER*)
BEGIN (*GETLINENRCALL*)
getfilename('INPUT ',[comma]);
load(gattr);
variable(fsys);
IF comptypes(gattr.typtr,packc5ptr) THEN store(regc,gattr)
ELSE error(458)
END (*GETLINENRCALL*);
PROCEDURE pagecall; (*WRITE A PAGEMARK INTO A TEXT FILE*)
BEGIN (*PAGECALL*)
getfilename('OUTPUT ',[rparent]);
support(putpage)
END (*PAGECALL*);
PROCEDURE datecall; (* ASSIGN DATE IN STANDARD DD-MMM-YY FORMAT TO ALFA PARAMETER *)
BEGIN (*DATECALL*)
variable(fsys);
IF comptypes(alfaptr,gattr.typtr) THEN load←address
ELSE error(458);
support(asciidate)
END (*DATECALL*);
PROCEDURE timecall; (* ASSIGN TIME IN STANDARD HH:MM:SS FORMAT TO ALFA PARAMETER *)
BEGIN (*TIMECALL*)
variable(fsys);
IF comptypes(alfaptr,gattr.typtr) THEN load←address
ELSE error(458);
support(asciitime)
END (*TIMECALL*);
PROCEDURE clockcall; (* RETURN THE ELAPSED CPU-TIME IN MILLISECONDS *)
BEGIN (*CLOCKCALL*)
WITH gattr DO
BEGIN
increment←regc; typtr := intptr; reg := regc; kind := expr;
macro3(047B,regc,30B(*PJOB-UUO*));
macro3(047B,regc,27B(*RUNTIM-UUO*))
END
END (*CLOCKCALL*);
PROCEDURE cardcall; (* RETURN THE CARDINAL NUMBER OF A SET *)
VAR
loop←around: addrrange;
BEGIN (*CARDCALL*)
WITH gattr DO
BEGIN
IF typtr <> NIL THEN
IF typtr↑.form <> power THEN error(459)
ELSE
BEGIN
increment←regc; increment←regc;
macro3(551B(*HRRZI*),regc,72);
macro2(400B(*SETZ*),regc-1);
loop←around := ic;
macro2(305B(*CAIGE*),gattr.reg - 1);
macro2(340B(*AOJ*),regc-1);
macro3(246B(*LSHC*),gattr.reg - 1,1);
macro3r(367B(*SOJG*),regc,loop←around);
regc := regc - 1;
kind := expr; reg := regc; typtr := intptr
END
END
END (*CARDCALL*);
(*abscall,realtimecall,sqrcall,oddcall,ordcall,chrcall,predsucc,eofeoln,protection,calltocall[getstringaddress],haltcall*)
PROCEDURE abscall; (*RETURN THE ABSOLUTE VALUE OF AN INTEGER OR REAL EXPRESSION*)
BEGIN (*ABSCALL*)
WITH gattr DO
IF (typtr = intptr) OR (typtr = realptr) THEN
IF kind=expr THEN macro3(214B(*MOVM*),reg,reg)
ELSE
BEGIN
increment←regc;
generate←code(214B(*MOVM*),regc,gattr)
END
ELSE
BEGIN
error(459); typtr:= intptr
END
END (*ABSCALL*) ;
PROCEDURE realtimecall; (* RETURN THE DAY-TIME IN MILLISECONDS *)
BEGIN (*REALTIMECALL*)
WITH gattr DO
BEGIN
increment←regc; typtr := intptr; reg := regc; kind := expr;
macro3(047B,regc,23B(*MSTIME-UUO*))
END
END (*REALTIMECALL*);
PROCEDURE sqrcall; (*RETURN THE SQUARE OF AN INTEGER OR REAL EXPRESSION*)
BEGIN (*SQRCALL*)
WITH gattr DO
IF typtr = intptr THEN macro3(220B(*IMUL*),reg,reg)
ELSE
IF typtr = realptr THEN macro3(164B(*FMPR*),reg,reg)
ELSE
BEGIN
error(459); typtr := intptr
END
END (*SQRCALL*) ;
PROCEDURE oddcall; (*RETURN TRUE IF THE INTEGER PARAMETER IS ODD*)
BEGIN (*ODDCALL*)
WITH gattr DO
BEGIN
IF typtr <> intptr THEN error(459);
macro3(405B(*ANDI*),reg,1);
typtr := boolptr
END
END (*ODDCALL*) ;
PROCEDURE ordcall; (*RETURN THE INTEGER (INTERNAL) VALUE OF A SCALAR*)
BEGIN (*ORDCALL*)
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form >= power THEN error(459);
gattr.typtr := intptr
END (*ORDCALL*) ;
PROCEDURE chrcall; (*RETURN THE CHARACTER WHOSE ASCII CODE IS THE PARAMETER*)
BEGIN (*CHR*)
IF gattr.typtr <> intptr THEN error(459);
gattr.typtr := charptr
END (*CHR*) ;
PROCEDURE predsucc;
VAR
lsp:stp;
pmin,pmax: integer;
BEGIN (*PREDSUCC*)
IF gattr.typtr <> NIL THEN
IF (gattr.typtr↑.form>subrange) OR (gattr.typtr=realptr) THEN error(459)
ELSE
BEGIN
lsp := gattr.typtr;
IF (lsp↑.form = subrange) THEN lsp := lsp↑.rangetype;
IF runtime←check AND (lsp <> intptr) THEN
BEGIN
IF lkey=8 THEN macro3r(365B(*SOJGE*),regc,ic+2)
ELSE
BEGIN
macro2(340B(*AOJ*),regc);
getbounds(lsp,pmin,pmax);
macro3(303B(*CAILE*),regc,pmax)
END;
support(errorinassignment)
END (* RUNTIME←CHECK *)
ELSE
IF lkey = 8 THEN macro2(360B(*SOJ*),regc)
ELSE macro2(340B(*AOJ*),regc)
END
END (*PREDSUCC*) ;
PROCEDURE eofeoln; (*RETURN TEH VALUE OF THE EOLN OR EOF FLAG OF THE FILE*)
BEGIN (*EOFEOLN*)
getfilename('INPUT ',[rparent]);
WITH gattr DO
BEGIN
increment←regc; generate←code(332B(*SKIPE*),regc,gattr);
macro3(551B(*HRRZI*),regc,1);
typtr := boolptr;
END
END (*EOFEOLN*) ;
PROCEDURE protection;
(* THIS PROCEDURE IS USED BY "PASDDT" TO TEST
IF A PROGRAM'S HIGH-SEGMENT IS SHARED
(WRITE-PROTECTED). PROGRAMS WHICH ARE
TO BE "DEBUGGED" MUST NOT BE SHARABLE.
FOR DETAILS SEE DECSYSTEM-10 "MONITOR-CALLS"
MANUAL, 3.2.4 *)
BEGIN (*PROTECTION*)
expression(fsys, onregc);
IF gattr.typtr = boolptr THEN
BEGIN
load(gattr);
macro3(047B,gattr.reg,36B(*SETUWP-UUO*));
macro3(254B(*HALT*),4,0)
END
ELSE error(458)
END (*PROTECTION*);
PROCEDURE calltocall;
(* THE STANDARD PROCEDURE
profuncall(<FILENAME>[,<DEVICE>[,<PROJECT-PROGRAMMER>[,<CORE-ASSIGNMENT]]])
ALLOWS TO EXIT FROM ONE PROGRAM AND EXECUTE ANOTHER *)
VAR
i:integer;
default:ARRAY[2..4] OF boolean;
PROCEDURE getstringaddress(flength: integer);
BEGIN (*GETSTRINGADDRESS*)
expression(fsys + [comma],onfixedregc);
WITH gattr DO
IF string(typtr) THEN
WITH typtr↑ DO
IF arraypf AND (size = 2) AND ((inxtype↑.vmax.ival-inxtype↑.vmin.ival+1) = flength) THEN load←address
ELSE error(458)
ELSE error(458)
END (*GETSTRINGADDRESS*);
BEGIN (* CALLTOCALL *)
%13 (* 14. EXTERNAL SUPPRESSED FROM PASSGO *)
IF NOT external THEN
BEGIN
(* 14.*) \
close←files;
getstringaddress(9);
FOR i := 2 TO 4 DO default[i] := true;
IF sy = comma THEN
BEGIN
insymbol; getstringaddress(6); default[2] := false;
IF sy = comma THEN
BEGIN
insymbol; expression(fsys + [comma],onfixedregc);
IF gattr.typtr = intptr THEN
BEGIN
default[3] := false; load(gattr)
END
ELSE error(458);
IF sy = comma THEN
BEGIN
insymbol; expression(fsys,onfixedregc);
IF gattr.typtr = intptr THEN
BEGIN
default[4] := false; load(gattr)
END
ELSE error(458)
END
END
END;
FOR i := 2 TO 4 DO
IF default[i] THEN
BEGIN
increment←regc; macro2(400B(*SETZ*),regc)
END;
support(runprogram);
%13 (* 14. EXTERNAL SUPPRESSED FROM PASSGO.*)
END
ELSE error(353)
(* 14.*) \
END (* CALLTOCALL *);
PROCEDURE haltcall; (*THIS PROCEDURE CALLS "PASDDT" IF IT IS LOADED, OTHERWISE IT
EXECUTES A "HALT" INSTRUCTION *)
BEGIN (*HALTCALL*)
macro3(332B(*SKIPE*),reg1,jbddt);
macro4(265B(*JSP*),reg0,reg1,-2);
macro2(254B(*HALT*),4)
END (*HALTCALL*);
(*call←non←standard[compparam,checksstringcalls,charconstant] ]profuncall*)
PROCEDURE call←non←standard;
VAR
lst,nxt,lnxt,lcp,lcp1: ctp;
lsp: stp;
lkind: idkind; pascalcall:boolean;
save←count,p,i,number←of←parameters: integer;
topp←offset,offset,start←of←parameterlist,actual←parameter,first←parameter,llc: addrrange;
lregc: acrange;
lalfa: alfa;
FUNCTION compparam(fcp1,fcp2 : ctp):boolean;
VAR
ok:boolean;
BEGIN (*COMPPARAM*)
ok:=true;
WHILE ok AND (fcp1<>NIL) AND (fcp2<>NIL) DO WITH fcp1↑ DO
BEGIN
IF comptypes(idtype,fcp2↑.idtype) THEN
IF klass=fcp2↑.klass THEN
IF klass=vars THEN
BEGIN
IF vkind<>fcp2↑.vkind THEN
BEGIN
error(370); ok:=false
END
END
ELSE ok:=compparam(fparam,fcp2↑.fparam)
ELSE
BEGIN
error(370); ok:=false
END
ELSE
BEGIN
error(370); ok:=false
END;
fcp1:=next; fcp2:=fcp2↑.next
END;
IF fcp1<>fcp2 THEN
BEGIN
error(554); compparam:=false
END
ELSE compparam:=ok
END(*COMPPARAM*);
(* 25. PASS THE STRING LENGTHS FOR STRING PROCEDURE CALLS.*)
PROCEDURE checksstringcalls;
VAR
i, j: integer;
BEGIN (*CHECKSSTRINGCALLS*);
IF sstringlength <> NIL THEN
IF lst <> NIL THEN
WITH sstringlength↑ DO
BEGIN
j := 1;
FOR i := 1 TO count DO
BEGIN
increment←regc;
macro3(551B(*HRRZI*),regc,value[i]);
IF regc > fcp↑.highest←register THEN
BEGIN
macro4(552B(*HRRZM*),regc,topp,lst↑.vaddr + lst↑.idtype↑.size + j);
regc := fcp↑.highest←register;
j := j + 1;
END;
END;
sstringlength := next;
END;
END (*CHECKSSTRINGCALLS*) (* 25.*);
(* 25. PUT CHARACTER CONSTANTS IN A PLACE IN MEMORY.*)
PROCEDURE charconstant (fchar: char);
VAR
lcsp: csp;
BEGIN (*CHARCONSTANT*)
new(lcsp,strg);
WITH lcsp↑ DO
BEGIN
slgth := 1; sval[1] := fchar;
END;
WITH gattr DO
BEGIN
typtr := packc1ptr;
kind := cst;
cval.valp := lcsp;
END
END (*CHARCONSTANT*);
BEGIN (* call←non←STANDARD *)
number←of←parameters:= 0; topp←offset := 0; start←of←parameterlist := 0;
actual←parameter := 0; lalfa := ' '; lst := NIL; (* 25.*)
pctp := fcp; (* 25.*)
WITH fcp↑ DO
BEGIN
lkind := pfkind;
IF lkind=actual THEN
BEGIN
nxt:=next;
%13 (* 17.*)
IF externdecl THEN library[language].called:=true;
(* 17.*) \
pascalcall:=language=pascalsy
END
ELSE (* LKIND <> ACTUAL *)
BEGIN
nxt:=fparam;
pascalcall:=true
END;
lnxt:=nxt;
IF klass = func THEN first←parameter := 2
ELSE first←parameter := 1;
save←count := regc - regin;
IF save←count > 0 THEN
BEGIN
llc := lc ;
lc := lc + save←count ;
IF lc > lcmax THEN lcmax := lc ;
IF save←count > 3 THEN
BEGIN
macro3(515B(*HRLZI*),reg1,2);
macro4(541B(*HRRI*),reg1,basis,llc);
macro4(251B(*BLT*),reg1,basis,llc+save←count-1)
END
ELSE FOR i := 1 TO save←count DO macro4(202B(*MOVEM*),regin+i,basis,llc+i-1)
END;
lregc:= regc;
IF lkind=actual THEN
IF language <> pascalsy THEN regc:= highest←register
ELSE regc:= regin
ELSE regc:=regin
END;
IF sy = lparent THEN
BEGIN (* PARAMETERS.*)
parsingparameters := true; (* 25. *)
sstringstart := true; (* 25. *)
REPEAT
recall := false; (* 25.*)
insymbol;
IF nxt=NIL THEN error(554)
ELSE
IF nxt↑.klass IN [proc,func] THEN
IF sy<>ident THEN error(209)
ELSE
BEGIN
searchid([proc,func],lcp);
insymbol;
WITH lcp↑ DO
IF pfdeckind=standard THEN error(510)
ELSE
BEGIN
IF pfkind=actual THEN lcp1:=next
ELSE lcp1:=fparam;
IF compparam(nxt↑.fparam,lcp1) THEN
IF nxt↑.klass<>klass THEN error(503)
ELSE
IF NOT comptypes(idtype,nxt↑.idtype) THEN error(555)
ELSE
BEGIN
increment←regc;
p:=level-pflev;
IF pfkind=actual THEN
IF language<>pascalsy THEN error(510)
ELSE
BEGIN
IF p=0 THEN macro3(514B(*HRLZ*),regc,basis)
ELSE
IF p=1 THEN macro4(514B(*HRLZ*),regc,basis,-1)
ELSE
IF p>1 THEN
BEGIN
macro4(550B(*HRRZ*),regc,basis,-1);
FOR i:=3 TO p DO macro4(550B(*HRRZ*),regc,regc,-1);
macro4(514B(*HRLZ*),regc,regc,-1)
END;
IF pfaddr=0 THEN
BEGIN
macro3(541B(*HRRI*),regc,linkchain[p]);
linkchain[p]:=ic-1;
IF externdecl THEN code←reference↑[cix]:=externref
ELSE
code←reference↑[cix]:=forwardref
END
ELSE macro3r(541B(*HRRI*),regc,pfaddr)
END
ELSE
BEGIN
IF p=0 THEN macro4(200B(*MOVE*),regc,basis,pfaddr)
ELSE
BEGIN
macro4(200B(*MOVE*),regc,basis,-1);
FOR i:=2 TO p DO
macro4(200B(*MOVE*),regc,regc,-1);
macro4(200B(*MOVE*),regc,regc,pfaddr)
END
END
END
END
END
ELSE (* NXT↑.KLASS = VARS *)
BEGIN
expression(fsys + [comma,rparent],onfixedregc);
IF gattr.typtr <> NIL THEN
IF nxt <> NIL THEN
BEGIN
lsp := nxt↑.idtype;
IF lsp <> NIL THEN
IF nxt↑.vkind = actual THEN
IF lsp↑.size <= 2 THEN
BEGIN
load(gattr);
IF comptypes(realptr,lsp) THEN makereal(gattr)
END
ELSE
BEGIN
IF lsp↑.form = files THEN
BEGIN
IF last←file <> NIL THEN
IF last←file↑.name = 'TTY ' THEN ttyread := true
ELSE
(* 13. REWRITE OUTPUT ONLY IF NEEDED.*)
IF last←file↑.name = 'OUTPUT ' THEN
outputwrite := true
END
ELSE
(* 25. PUT CHARACTER CONSTANTS IN A PLACE IN MEMORY.*)
IF stringpack THEN
IF lsp = sstringptr THEN
WITH gattr DO
IF (typtr↑.bitsize = 7) AND (kind = cst) THEN
charconstant(chr(cval.ival));
load←address;
IF fcp↑.language <> pascalsy THEN code←array↑.instruction[cix].instr := 515B(*HRLZI*)
END
ELSE
WITH gattr DO
IF kind = varbl THEN load←address
ELSE error(463);
IF NOT comptypes(lsp,gattr.typtr) THEN error(503)
ELSE
(* 25. REJECT NON-SSTRING ON VAR PARAMETERS.*)
IF stringpack THEN
IF lsp = sstringptr THEN
WITH sstringlength↑ DO
IF nxt↑.vkind = formal THEN
BEGIN
IF value[count]
<> xtrastrglgth THEN
error(469);
count := count - 1;
END
ELSE
IF (gattr.typtr↑.form <> arrays) AND (value[count] = 1) THEN
value[count] := xtrastrglgth + 1;
END
END;
IF regc > fcp↑.highest←register THEN
BEGIN
IF topp←offset = 0 THEN
BEGIN
IF fcp↑.pfkind=formal THEN topp←offset:=fcp↑.parlistsize+1
ELSE
IF fcp↑.language = pascalsy THEN topp←offset:=fcp↑.parlistsize+1
ELSE
BEGIN
topp←offset := 1 + first←parameter;
REPEAT
WITH lnxt↑ DO
BEGIN
number←of←parameters := number←of←parameters +1;
topp←offset := topp←offset + 1;
IF vkind = actual THEN
IF idtype<>NIL THEN
topp←offset := topp←offset + idtype↑.size;
lnxt := next
END;
UNTIL lnxt = NIL;
start←of←parameterlist := 1 + first←parameter;
actual←parameter := start←of←parameterlist + number←of←parameters
END;
macro3(271B(*ADDI*),topp,topp←offset)
END ;
WITH nxt↑ DO
BEGIN
IF pascalcall THEN
BEGIN
IF klass<>vars THEN macro4(202B(*MOVEM*),regc,topp,pfaddr+1-topp←offset)
ELSE
IF (idtype↑.size <> 2) OR (vkind = formal) THEN macro4(202B(*MOVEM*),regc,topp,vaddr+1-topp←offset)
ELSE
BEGIN
macro4(202B(*MOVEM*),regc,topp,vaddr+2-topp←offset);
IF regc>fcp↑.highest←register+1 THEN
macro4(202B(*MOVEM*),regc-1,topp,vaddr+1-topp←offset)
END
END
ELSE
BEGIN
IF klass<>vars THEN error(468)
ELSE
IF vkind = actual THEN
IF idtype<>NIL THEN
BEGIN
IF idtype↑.size <= 2 THEN
BEGIN
IF idtype↑.size = 2 THEN
BEGIN
macro4(202B(*MOVEM*),regc,topp,actual←parameter+1-topp←offset);
regc := regc - 1
END;
macro4(202B(*MOVEM*),regc,topp,actual←parameter-topp←offset);
macro4(541B(*HRRI*),regc,topp,actual←parameter-topp←offset)
END
ELSE
BEGIN
macro4(541B(*HRRI*),regc,topp,actual←parameter-topp←offset);
macro4(251B(*BLT*),regc,topp,actual←parameter+idtype↑.size-1-topp←offset)
END;
actual←parameter := actual←parameter + idtype↑.size
END;
macro4(552B(*HRRZM*),regc,topp,start←of←parameterlist-topp←offset);
start←of←parameterlist := start←of←parameterlist + 1
END;
regc := fcp↑.highest←register
END
END;
(*REGC>FCP↑.HIGHEST←REGISTER*)
lst := nxt;
IF nxt <> NIL THEN nxt := nxt↑.next;
skipiferr([comma,rparent],256,fsys)
UNTIL sy <> comma;
parsingparameters := false; (* 25.*)
IF sy = rparent THEN insymbol
ELSE error(152)
END (*IF LPARENT*);
IF nxt<>NIL THEN error(554);
FOR i := 0 TO withix DO
WITH display[top-i] DO
IF (cindr<>0) AND (cindr<>basis) THEN macro4(202B(*MOVEM*),cindr,basis,clc);
WITH fcp↑ DO
BEGIN
IF lkind=formal THEN
BEGIN
IF topp←offset<>0 THEN macro3(275B(*SUBI*),topp,topp←offset)
END
ELSE
IF (language = pascalsy) AND (topp←offset <> 0) THEN macro3(275B(*SUBI*),topp,topp←offset)
ELSE
IF (language <> pascalsy) AND (topp←offset = 0) THEN
BEGIN
topp←offset:= first←parameter+2;
macro3(271B(*ADDI*),topp,topp←offset)
END;
IF pflev > 1 THEN p := level - pflev
ELSE p:= 0;
IF lkind = actual THEN
BEGIN
IF language <> pascalsy THEN
BEGIN
macro3(515B(*HRLZI*),reg0,-number←of←parameters);
macro4(202B(*MOVEM*),reg0,topp,first←parameter-topp←offset);
macro4(202B(*MOVEM*),basis,topp,-topp←offset);
macro4(551B(*HRRZI*),basis,topp,first←parameter-topp←offset+1);
IF number←of←parameters = 0 THEN macro4(402B(*SETZM*),0,topp,first←parameter-topp←offset+1)
END;
IF stringpack THEN (* 25.*)
checksstringcalls;
IF pfaddr = 0 THEN
BEGIN
macro3r(260B(*PUSHJ*),topp,linkchain[p]); linkchain[p]:= ic-1;
IF externdecl THEN code←reference↑[cix] := externref
ELSE code←reference↑[cix] := forwardref
END
ELSE macro3r(260B(*PUSHJ*),topp,pfaddr-p);
IF language <> pascalsy THEN
BEGIN
macro3(275B(*SUBI*),topp,topp←offset);
IF klass = func THEN
BEGIN
macro4(202B(*MOVEM*),reg0,topp,2);
IF idtype↑.size = 2 THEN macro4(202B(*MOVEM*),reg1,topp,3)
END;
macro4(200B(*MOVE*),basis,topp,0)
END;
END
ELSE (*LKIND=FORMAL*)
BEGIN
IF p=0 THEN
BEGIN
macro4(550B(*HRRZ*),reg1,basis,pfaddr);
macro4(544B(*HLR*),basis,basis,pfaddr)
END
ELSE
BEGIN
macro4(550B(*HRRZ*),reg1,basis,-1);
FOR i:=2 TO p DO macro4(550B(*HRRZ*),reg1,reg1,-1);
macro4(544B(*HLR*),basis,reg1,pfaddr);
macro4(550B(*HRRZ*),reg1,reg1,pfaddr)
END;
IF stringpack THEN (* 25.*)
checksstringcalls;
macro4(260B(*PUSHJ*),topp,reg1,0)
END
END;
FOR i := 0 TO withix DO
WITH display[top-i] DO
IF (cindr<>0) AND (cindr<>basis) THEN macro4(200B(*MOVE*),cindr,basis,clc) ;
IF save←count > 0 THEN
BEGIN
IF save←count > 3 THEN
BEGIN
macro4(515B(*HRLZI*),reg1,basis,llc);
macro3(541B(*HRRI*),reg1,2);
macro3(251B(*BLT*),reg1,save←count+1)
END
ELSE FOR i := 1 TO save←count DO macro4(200B(*MOVE*),regin+i,basis,llc+i-1) ;
lc := llc
END ;
gattr.typtr := fcp↑.idtype; regc := lregc
END (*call←non←STANDARD*) ;
BEGIN (*profuncall*)
noload := false;
tty←message := false;
buffer←variable := false;
IF fcp↑.pfdeckind = standard THEN
BEGIN (* STANDARD PROCEDURES *)
lkey := fcp↑.key; lclass := fcp↑.klass;
IF fcp↑.klass = proc THEN
BEGIN
IF NOT (lkey IN [1..11,17,19,25..27,29]) THEN
IF sy = lparent THEN insymbol
ELSE error(153);
fsys := fsys + [rparent];
IF (lkey IN [5..8,10,11,26..29]) AND (regcmax <= 8) (*<--- REG2..8 USED BY RUNTIME-SUPPORT*) THEN error(317);
CASE lkey OF
1,2,3,4,
5,6:
getputresetrewrite;
7, 8:
BEGIN
readreadln;
IF no←right←parent THEN GOTO 666
END;
9:
BEGIN
breakcall ;
IF no←right←parent THEN GOTO 666
END ;
10, 11:
BEGIN
writewriteln;
IF no←right←parent THEN GOTO 666
END;
12, 13:
packunpack;
14, 24:
newdispose;
17:
BEGIN
noload := true;
getlinenrcall
END;
19:
BEGIN
pagecall;
IF no←right←parent THEN GOTO 666
END;
20:
protection;
21:
calltocall;
22:
datecall;
23:
timecall;
25:
BEGIN
haltcall;
GOTO 666
END;
28:
messagecall;
OTHERS:
errandskip(169,fsys)
END
END
ELSE (* FCP↑.KLAS <> PROC : STANDARD FUNCTIONS *)
BEGIN
IF lkey IN [2..9,13..16,19..22] THEN
BEGIN
IF sy = lparent THEN insymbol
ELSE error(153);
IF lkey IN [2..9,13,14,18] THEN
expression(fsys + [rparent,comma],onregc);
IF lkey IN [3..5,8,9,13,14,18] THEN load(gattr)
END;
CASE lkey OF
1:
realtimecall;
2:
abscall;
3:
sqrcall;
5:
oddcall;
6:
ordcall;
7:
chrcall;
8,9:
predsucc;
10,11:
BEGIN
noload := true;
eofeoln;
IF no←right←parent THEN GOTO 666
END;
12:
clockcall;
13:
cardcall;
15,16:
lowerupperbound;
19,20:
minmax;
21,22:
firstlast;
OTHERS:
errandskip(169,fsys + [rparent])
END;
IF lkey IN [1,12] THEN GOTO 666
END;
IF sy = rparent THEN insymbol
ELSE error(152);
666:
END (*STANDARD PROCEDURES AND FUNCTIONS*)
ELSE call←non←standard
END (*profuncall*) ;
(* EXPRESSION[changebool, searchcode, simpleexpression[term[factor]]] *)
PROCEDURE expression; (*(FSYS: SETOFSYS; FVALUE:VALUEKIND)*)
VAR
jump←offset: 2..4;
default←offset: 4..5;
lattr: attr;
lop: operator;
lsize: addrrange;
default,jump: boolean;
boolregc,testregc,lregc1,lregc2:acrange;
linstr,linstr1: instrange;
setinclusion : boolean;
jmpadrifallequal : integer;
PROCEDURE changebool(VAR finstr: instrange);
BEGIN (*CHANGEBOOL*)
IF (finstr>=311B) AND (finstr<=313B) THEN finstr := finstr+4 (*CAML,CAME,CAMLE --> CAMGE,CAMN,CAMG*)
ELSE
IF (finstr>=315B) AND (finstr<=317B) THEN finstr := finstr-4 (*SAME IN THE OTHER WAY*)
END (*CHANGEBOOL*);
PROCEDURE searchcode(finstr:instrange; fattr: attr);
PROCEDURE changeoperands(VAR finstr:instrange);
BEGIN (*CHANGEOPERANDS*)
IF finstr=311B(*CAML*) THEN finstr := 317B(*CAMG*)
ELSE
IF finstr = 313B(*CAMLE*) THEN finstr := 315B(*CAMGE*)
ELSE
IF finstr=315B(*CAMGE*) THEN finstr := 313B(*CAMLE*)
ELSE
IF finstr = 317B(*CAMG*) THEN finstr := 311B(*CAML*)
ELSE
IF finstr = 420B(*ANDCM*) THEN finstr := 410B(*ANDCA*)
ELSE
IF finstr = 410B(*ANDCA*) THEN finstr := 420B(*ANDCM*)
END (*CHANGEOPERANDS*);
BEGIN (*SEARCHCODE*)
WITH gattr DO
IF fattr.kind = expr THEN
BEGIN
generate←code(finstr,fattr.reg,gattr); reg := fattr.reg
END
ELSE
IF kind = expr THEN
BEGIN
changeoperands(finstr); generate←code(finstr,reg,fattr)
END
ELSE
IF (kind=varbl) AND ((packfg<>notpack)
OR (indexr>regin) AND (indexr<=regcmax) AND
((fattr.indexr<=regin) OR (fattr.indexr>regcmax))) THEN
BEGIN
load(gattr); changeoperands(finstr); generate←code(finstr,reg,fattr)
END
ELSE
BEGIN
load(fattr); generate←code(finstr,fattr.reg,gattr); reg := fattr.reg
END
END (*SEARCHCODE*);
PROCEDURE simpleexpression(fsys: setofsys);
VAR
lattr: attr; lop: operator; signed : boolean;
PROCEDURE term(fsys: setofsys);
VAR
lattr: attr; lop: operator;
PROCEDURE factor(fsys: setofsys);
VAR
lcp: ctp; lvp: csp; varpart: boolean;
cstpart: SET OF setrange; lsp: stp;
rangepart: boolean; lrmin: setrange;
loffset: 0..offset ;
BEGIN (*FACTOR*)
IF NOT (sy IN facbegsys) THEN
BEGIN
errandskip(173,fsys + facbegsys);
gattr.typtr := NIL
END;
IF sy IN facbegsys THEN
BEGIN
CASE sy OF
ident:
BEGIN
searchid([konst,vars,field,func],lcp);
insymbol;
CASE lcp↑.klass OF
func:
BEGIN
profuncall(fsys,lcp);
IF lcp↑.pfdeckind=declared THEN
BEGIN
WITH lcp↑,gattr DO
BEGIN
typtr :=idtype; kind :=varbl; packfg :=notpack;
vrelbyte := no;
vlevel :=1; dplmt :=2;
indexr := topp; indbit :=0;
IF typtr <> NIL THEN
IF typtr↑.size = 1 THEN load(gattr)
END
END
END;
konst:
WITH gattr, lcp↑ DO
BEGIN
typtr := idtype; kind := cst;
cval := values
END;
OTHERS:
selector(fsys,lcp)
END (*CASE KLASS*);
IF gattr.typtr <> NIL THEN WITH gattr, typtr↑ DO
IF form = subrange then (*ELIMINAte subrange types*)
begin
subkind := typtr;
typtr := rangetype (*TO SIMPLIFY LATER TESTS*)
end;
END;
intconst:
BEGIN
WITH gattr DO
BEGIN
typtr := intptr; kind := cst;
cval := val
END;
insymbol
END;
realconst:
BEGIN
WITH gattr DO
BEGIN
typtr := realptr; kind := cst;
cval := val
END;
insymbol
END;
stringconst:
BEGIN
WITH gattr DO
BEGIN
constant(fsys,typtr,cval) ; kind := cst
END
END;
lparent:
BEGIN
insymbol; expression(fsys + [rparent],onregc);
IF sy = rparent THEN insymbol
ELSE error(152)
END;
notsy:
BEGIN
insymbol; factor(fsys);
IF gattr.typtr = boolptr THEN
BEGIN
load(gattr); macro3(411B(*ANDCAI*),regc,1)
END
ELSE
BEGIN
error(359); gattr.typtr := NIL
END
END;
lbrack:
BEGIN
insymbol; cstpart := [ ]; varpart := false;
rangepart:=false;
new(lsp,power);
WITH lsp↑ DO
BEGIN
elset:=NIL; size:= 2
END;
IF sy = rbrack THEN
BEGIN
WITH gattr DO
BEGIN
typtr:=lsp; kind:=cst;
new(lvp,pset); lvp↑.pval := cstpart; cval.valp := lvp
END;
insymbol
END
ELSE
BEGIN
LOOP
increment←regc; increment←regc;
expression(fsys + [comma,rbrack,colon],onregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN
BEGIN
error(461); gattr.typtr := NIL
END
ELSE
IF comptypes(lsp↑.elset,gattr.typtr) THEN
WITH gattr DO
BEGIN
IF kind = cst THEN
BEGIN
IF comptypes(typtr,asciiptr) THEN cval.ival := cval.ival-offset;
IF (cval.ival < 0) OR (cval.ival > basemax) THEN error(268)
ELSE cstpart := cstpart + [cval.ival];
regc := regc - 2;
IF sy=colon THEN
BEGIN
rangepart:=true;
lrmin:=cval.ival
END
ELSE
IF rangepart THEN
BEGIN
lrmin:=lrmin+1;
WHILE (lrmin<cval.ival) DO
BEGIN
cstpart:=cstpart + [lrmin];
lrmin:=lrmin+1
END;
rangepart:=false
END
END
ELSE
BEGIN
IF (sy=colon) OR rangepart THEN
BEGIN
error(207);rangepart := NOT rangepart
END;
load(gattr);
regc := regc -1;
macro3(515B(*HRLZI*),regc-1,400000B);
macro2(400B(*SETZ*),regc);
IF runtime←check THEN
BEGIN
IF comptypes(typtr,asciiptr) THEN loffset := offset
ELSE loffset := 0 ;
macro3(301B(*CAIL*),regc+1,loffset);
macro3(303B(*CAILE*),regc+1,basemax+loffset);
support(errorinset)
END;
macro3(210B(*MOVN*),regc+1,regc+1);
IF comptypes(typtr,asciiptr) THEN macro4(246B(*LSHC*),regc-1,regc+1,offset)
ELSE macro4(246B(*LSHC*),regc-1,regc+1,0);
IF varpart THEN
BEGIN
macro3(434B(*IOR*),regc-3,regc-1);
macro3(434B(*IOR*),regc-2,regc);
regc := regc - 2
END
ELSE varpart := true;
kind := expr; reg := regc
END;
lsp↑.elset := typtr;
typtr :=lsp
END
ELSE error(360)
EXIT IF NOT(sy IN [comma,colon]);
insymbol
END;
IF sy = rbrack THEN insymbol
ELSE error(155);
IF varpart THEN
BEGIN
IF cstpart <> [ ] THEN
BEGIN
new(lvp,pset); lvp↑.pval := cstpart;
gattr.kind := cst; gattr.cval.valp := lvp;
generate←code(434B(*IOR*),regc,gattr)
END
END
ELSE
BEGIN
new(lvp,pset); lvp↑.pval := cstpart; gattr.cval.valp := lvp
END
END
END
END (*CASE*) ;
iferrskip(166,fsys)
END (*IF SY IN FACBEGSYS*)
END (*FACTOR*) ;
BEGIN (*TERM*)
factor(fsys + [mulop]);
WHILE sy = mulop DO
BEGIN
IF op IN [rdiv,idiv,imod] THEN load(gattr);
(*BECAUSE OPERANDS ARE NOT
ALLOWED TO BE CHOSEN*)
lattr := gattr; lop := op;
insymbol; factor(fsys + [mulop]);
IF (lattr.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
CASE lop OF
mul:
IF comptypes(lattr.typtr,gattr.typtr)
AND (gattr.typtr↑.form = power) THEN searchcode(404B(*AND*),lattr)
ELSE
IF (lattr.typtr = intptr) AND (gattr.typtr = intptr) THEN searchcode(220B(*IMUL*),lattr)
ELSE
BEGIN
makereal(lattr);
IF (lattr.typtr = realptr) AND (gattr.typtr = realptr) THEN searchcode(164B(*FMPR*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END;
rdiv:
BEGIN
makereal(lattr);
IF (lattr.typtr = realptr) AND (gattr.typtr = realptr) THEN searchcode(174B(*FDVR*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END;
idiv:
IF (lattr.typtr = intptr) AND (gattr.typtr = intptr) THEN searchcode(230B(*IDIV*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END;
imod:
IF (lattr.typtr = intptr) AND (gattr.typtr = intptr) THEN
BEGIN
searchcode(230B(*IDIV*),lattr);gattr.reg := gattr.reg+1
END
ELSE
BEGIN
error(311); gattr.typtr := NIL
END;
andop:
IF comptypes(lattr.typtr,gattr.typtr)
AND (gattr.typtr = boolptr) THEN searchcode(404B(*AND*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END (*CASE*)
ELSE gattr.typtr := NIL;
regc:=gattr.reg
END (*WHILE*)
END (*TERM*) ;
BEGIN (*SIMPLEEXPRESSION*)
signed := false;
IF (sy = addop) AND (op IN [plus,minus]) THEN
BEGIN
signed := op = minus; insymbol
END;
term(fsys + [addop]);
IF signed THEN WITH gattr DO
IF typtr <> NIL THEN
IF (typtr = intptr) OR (typtr = realptr) THEN
CASE kind OF
cst:
IF typtr = intptr THEN cval.ival := - cval.ival
ELSE
BEGIN
increment←regc;
generate←code(210B(*MOVN*),regc,gattr)
END;
varbl:
BEGIN
increment←regc;
generate←code(210B(*MOVN*),regc,gattr)
END;
expr:
macro3(210B(*MOVN*),reg,reg)
END (*CASE*)
ELSE
BEGIN
error(311) ; gattr.typtr := NIL
END ;
WHILE sy = addop DO
BEGIN
IF aos = b2 THEN
IF (leftside.packfg=notpack) AND comptypes(leftside.typtr,intptr) THEN
BEGIN
leftside.typtr:=intptr; leftside.bpaddr:=gattr.bpaddr;
IF leftside=gattr THEN aos := b3
ELSE aos:=b0
END
ELSE aos := b0
ELSE aos := b0;
IF op=minus THEN load(gattr);
(*BECAUSE OPD MAY NOT BE CHOSEN*)
lattr := gattr; lop := op;
insymbol; term(fsys + [addop]);
IF aos=b3 THEN
IF gattr.kind<>cst THEN aos:=b0;
IF (lattr.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
CASE lop OF
plus:
IF comptypes(lattr.typtr,gattr.typtr)
AND (gattr.typtr↑.form = power) THEN searchcode(434B(*IOR*),lattr)
ELSE
IF (lattr.typtr = intptr) AND (gattr.typtr = intptr) THEN
BEGIN
IF aos=b3 THEN
IF gattr.cval.ival=1 THEN aos := aosinstr;
searchcode(270B(*ADD*),lattr)
END
ELSE
BEGIN
makereal(lattr);
IF (lattr.typtr=realptr) AND (gattr.typtr=realptr) THEN searchcode(144B(*FADR*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END;
minus:
IF (lattr.typtr=intptr) AND (gattr.typtr=intptr) THEN
BEGIN
IF aos=b3 THEN
IF gattr.cval.ival=1 THEN aos := sosinstr;
searchcode(274B(*SUB*),lattr)
END
ELSE
BEGIN
makereal(lattr);
IF (lattr.typtr = realptr) AND (gattr.typtr = realptr) THEN searchcode(154B(*FSBR*),lattr)
ELSE
IF comptypes(lattr.typtr,gattr.typtr)
AND (lattr.typtr↑.form = power) THEN searchcode(420B(*ANDCM*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END;
orop:
IF comptypes(lattr.typtr,gattr.typtr)
AND (gattr.typtr = boolptr) THEN searchcode(434B(*IOR*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END (*CASE*)
ELSE gattr.typtr := NIL;
regc:=gattr.reg;
IF aos <= b3 THEN aos := b0
END (*WHILE*);
IF aos <= b3 THEN aos := b0
END (*SIMPLEEXPRESSION*) ;
BEGIN (*EXPRESSION*)
testregc := regc+1;
IF aos=b1 THEN aos:=b2
ELSE aos:=b0;
simpleexpression(fsys + [relop]);
IF sy = relop THEN
BEGIN
jump := false;
IF fvalue IN [onregc,onfixedregc] THEN
BEGIN
increment←regc; macro3(551B(*HRRZI*),regc,1); boolregc := regc
END;
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.size > 2 THEN load←address;
lregc1 := regc;
lattr := gattr;
lop := op;
IF (fvalue IN [onregc,onfixedregc]) AND (regc < boolregc) THEN regc := boolregc;
insymbol; simpleexpression(fsys);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.size > 2 THEN load←address;
lregc2 := regc;
IF (lattr.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
BEGIN
IF lop = inop THEN
IF gattr.typtr↑.form = power THEN
IF comptypes(lattr.typtr,gattr.typtr↑.elset) THEN
BEGIN
load(lattr);
IF (fvalue IN [onregc,onfixedregc]) AND (regc < boolregc) THEN regc := boolregc;
load(gattr); regc := gattr.reg - 1;
IF comptypes(lattr.typtr,asciiptr) THEN macro4(246B(*LSHC*),regc,lattr.reg,-offset)
ELSE macro4(246B(*LSHC*),regc,lattr.reg,0);
IF fvalue = truejmp THEN linstr := 305B(*CAIGE*)
ELSE linstr := 301B(*CAIL*);
macro2(linstr,regc)
END
ELSE
BEGIN
error(260); gattr.typtr := NIL
END
ELSE
BEGIN
error(213); gattr.typtr := NIL
END
ELSE
BEGIN
IF lattr.typtr <> gattr.typtr THEN makereal(lattr);
IF comptypes(lattr.typtr,gattr.typtr) THEN
BEGIN
lsize := lattr.typtr↑.size;
CASE lattr.typtr↑.form OF
power:
IF lop IN [ltop,gtop] THEN error(313);
arrays:
IF NOT string(lattr.typtr)
AND (lop IN [ltop,leop,gtop,geop]) THEN error(312);
pointer,
records:
IF lop IN [ltop,leop,gtop,geop] THEN error(312);
files:
error(314)
END;
WITH lattr.typtr↑ DO
BEGIN
IF size <= 2 THEN
BEGIN
default := true;
setinclusion := false;
jump←offset := 3;
default←offset := 4;
CASE lop OF
ltop:
BEGIN
linstr := 311B(*CAML*); linstr1 := 313B
END;
leop:
IF form = power THEN
BEGIN
searchcode(420B(*ANDCM*),lattr);
setinclusion := true
END
ELSE
BEGIN
linstr := 313B(*CAMLE*); linstr1 := 313B
END;
gtop:
BEGIN
linstr := 317B(*CAMG*); linstr1 := 315B
END;
geop:
IF form = power THEN
BEGIN
searchcode(410B(*ANDCA*),lattr);
setinclusion := true
END
ELSE
BEGIN
linstr := 315B(*CAMGE*); linstr1 := 315B
END;
neop:
BEGIN
linstr := 316B(*CAMN*);default := false
END;
eqop:
BEGIN
linstr := 312B(*CAME*); default := false
END
END;
IF fvalue IN [truejmp,falsejmp] THEN
BEGIN
IF (form = scalar) AND (gattr.kind = cst) THEN
IF lattr.typtr = realptr THEN jump := gattr.cval.valp↑.rval = 0.0
ELSE
IF gattr.cval.ival = 0 THEN jump := true;
IF (fvalue = truejmp) <> jump THEN changebool(linstr);
IF jump THEN linstr := linstr + 10B (*E.G CAML --> JUMPL *)
END;
IF size = 1 THEN
IF jump THEN
BEGIN
load(lattr); macro3(linstr,lattr.reg,0)
END
ELSE searchcode(linstr,lattr)
ELSE
IF setinclusion THEN
BEGIN
macro3(336B(*SKIPN*),0,gattr.reg);
macro3(332B(*SKIPE*),0,gattr.reg-1);
IF fvalue = truejmp THEN macro3r(254B(*JRST*),0,ic+2)
END
ELSE
BEGIN
load(lattr);
IF (fvalue IN [onregc,onfixedregc]) AND (regc<boolregc) THEN regc := boolregc;
load(gattr);
CASE fvalue OF
onregc,
onfixedregc,
falsejmp:
IF lop = eqop THEN jump←offset := 2;
truejmp:
IF lop <> eqop THEN
BEGIN
jump←offset := 2; default←offset := 5
END
END;
IF default THEN
BEGIN
macro3(linstr1,lattr.reg-1,gattr.reg-1);
macro3r(254B(*JRST*),0,ic + default←offset)
END;
macro3(312B(*CAME*),lattr.reg-1,gattr.reg-1);
macro3r(254B(*JRST*),0,ic+jump←offset);
macro3(linstr,lattr.reg,gattr.reg)
END
END
ELSE
BEGIN
macro3(551B(*HRRZI*),reg0,lsize);
increment←regc ;
macro4(200B(*MOVE*),regc,lregc1,0);
macro4(312B(*CAME*),regc,lregc2,0);
macro3r(254B(*JRST*),0,ic+5);
macro2(340B(*AOJ*),lregc1);
macro2(340B(*AOJ*),lregc2);
macro3r(367B(*SOJG*),reg0,ic-5);
jmpadrifallequal := 0;
CASE lop OF
ltop,gtop:
IF fvalue=truejmp THEN jmpadrifallequal := 3
ELSE jmpadrifallequal := 2;
leop,geop:
IF fvalue=truejmp THEN jmpadrifallequal := 2
ELSE jmpadrifallequal := 3;
eqop :
IF fvalue<>truejmp THEN jmpadrifallequal := 2;
neop :
IF fvalue=truejmp THEN jmpadrifallequal := 2
END;
IF jmpadrifallequal <> 0 THEN macro4r(254B(*JRST*),0,0,ic+jmpadrifallequal);
CASE lop OF
ltop,leop:
linstr := 311B(*CAML*);
gtop,geop:
linstr := 317B(*CAMG*)
END;
IF fvalue=truejmp THEN changebool(linstr);
IF lop IN [ltop,leop,gtop,geop] THEN macro4(linstr,regc,lregc2,0);
regc:=regc-2
END
END
END
ELSE error(260)
END;
IF fvalue IN [onregc,onfixedregc] THEN
BEGIN
macro3(400B(*SETZ*),boolregc,0); regc := boolregc
END
ELSE
IF NOT jump THEN macro3(254B(*JRST*),0,0)
END;
gattr.typtr := boolptr; gattr.kind := expr; gattr.reg := regc
END (*SY = RELOP*)
ELSE
IF fvalue IN [truejmp,falsejmp] THEN
BEGIN
load(gattr);
IF gattr.typtr<>boolptr THEN error (359);
IF fvalue = truejmp THEN linstr := 326B(*JUMPN*)
ELSE linstr := 322B(*JUMPE*);
macro3(linstr,gattr.reg,0)
END
ELSE
IF gattr.kind=expr THEN regc := gattr.reg;
IF fvalue = onfixedregc THEN WITH gattr DO
IF (typtr <> NIL) AND (kind=expr) THEN WITH typtr↑ DO
BEGIN
IF size = 2 THEN testregc := testregc + 1;
IF testregc <> regc THEN
BEGIN
IF size = 2 THEN macro3(200B(*MOVE*),testregc-1,regc-1);
macro3(200B(*MOVE*),testregc,regc); regc := testregc;reg := regc
END
END
END (*EXPRESSION*) ;
(* assignment[storeglobals[storeword,getnewglobptr]] *)
PROCEDURE assignment(fcp: ctp);
VAR
slattr: attr;
cmin, cmax: valu;
leftside←real: boolean;
linstr: instrange;
oldix: coderange;
oldic: addrrange;
%13 (* 17.*)
PROCEDURE storeglobals ;
TYPE
changeform = (ptrw,intw,reelw,psetw,strgw,instw) ;
VAR
change : RECORD
CASE kw : changeform OF
ptrw: (wptr :gtp (*TO ALLOW NIL*)) ;
intw: (wint : integer ; wint1 : integer (*TO PICK UP SECOND WORD OF SET*)) ;
reelw: (wreel: real) ;
psetw: (wset : SET OF setrange) ;
strgw: (wstrg: charword) ;
instw: (winst: pdp10instr)
END ;
i: 1..strglgth; j: 0..5;
PROCEDURE storeword ;
BEGIN (*STOREWORD*)
cix := cix + 1 ;
IF cix > code←size THEN
BEGIN
cix := 0;
IF NOT overrun THEN
BEGIN
overrun := true;
error←with←text(356,'INITPROCD.')
END
END ;
WITH cglobptr↑ DO
BEGIN
code←array↑.instruction[cix] := change.winst ;
lastglob := lastglob + 1
END
END (*STOREWORD*) ;
PROCEDURE getnewglobptr ;
VAR
lglobptr : gtp ;
BEGIN (*GETNEWGLOBPTR*)
new(lglobptr) ;
WITH lglobptr↑ DO
BEGIN
nextglobptr := NIL ;
firstglob := 0
END ;
IF cglobptr <> NIL THEN cglobptr↑.nextglobptr := lglobptr ;
cglobptr := lglobptr
END (*GETNEWGLOBPTR*);
BEGIN
(*STOREGLOBALS*)
IF fglobptr = NIL THEN
BEGIN
getnewglobptr ;
fglobptr := cglobptr
END
ELSE
IF leftside.dplmt <> cglobptr↑.lastglob + 1 THEN getnewglobptr ;
WITH change,cglobptr↑,gattr,cval DO
BEGIN
IF firstglob = 0 THEN
BEGIN
IF leftside.packfg<>notpack THEN
IF errlist[errinx].arw<>507 THEN error(507);
firstglob := leftside.dplmt ;
lastglob := firstglob - 1 ;
fcix := cix + 1
END ;
CASE typtr↑.form OF
scalar,
subrange:
BEGIN
IF leftside←real THEN
IF typtr=intptr THEN wreel := ival
ELSE wreel := valp↑.rval
ELSE wint := ival ;
storeword
END ;
pointer :
BEGIN
wptr := NIL ; storeword
END ;
power :
BEGIN
wset := valp↑.pval ; storeword ;
wint := wint1 (*GET SECOND WORD OF SET*) ;
storeword
END ;
arrays :
WITH valp↑,change DO
BEGIN
j := 0; wint := 0;
FOR i := 1 TO slgth DO
BEGIN
j := j + 1;
wstrg[j] := sval[i];
IF j=5 THEN
BEGIN
j := 0;
storeword; wint := 0
END
END;
IF j<>0 THEN storeword
END;
OTHERS :
error(411)
END (*CASE*)
END (* WITH *)
END (* STOREGLOBALS *) ;
(* 17.*) \
BEGIN (*ASSIGNMENT*)
selector(fsys + [becomes],fcp);
IF sy = becomes THEN
BEGIN
leftside := gattr;
leftside←real := comptypes(leftside.typtr,realptr);
IF NOT runtime←check THEN
BEGIN
aos := b1; oldix:=cix; oldic:=ic
END;
insymbol;
expression(fsys,onregc);
IF (leftside.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
IF comptypes(leftside.typtr,gattr.typtr) OR
leftside←real AND (gattr.typtr=intptr) THEN
%24
BEGIN (* 24.*) \
IF initglobals THEN
IF gattr.kind = cst THEN %13 storeglobals (* 17.*) \
ELSE error(504)
%13
ELSE \ %24 ;
(* 24.*) \
IF (gattr.kind=cst) AND (gattr.cval.ival=0) AND
(leftside.packfg<>packk) THEN WITH leftside DO
BEGIN
fetch←basis(leftside);
WITH typtr↑ DO
IF form = subrange THEN
IF leftside←real THEN
BEGIN
IF (vmin.valp↑.rval > 0) OR (vmax.valp↑.rval < 0) THEN error(367)
END
ELSE
IF (vmin.ival > 0) OR (vmax.ival < 0) THEN error(367) ;
CASE packfg OF
notpack:
linstr := 402B(*SETZM*);
hwordl:
linstr := 553B(*HRRZS*);
hwordr:
linstr := 513B(*HLLZS*)
END (*CASE*);
macro(vrelbyte,linstr,0,indbit,indexr,dplmt)
END
ELSE
IF aos >= aosinstr THEN
BEGIN
ic := oldic; cix := oldix;
IF aos=aosinstr THEN generate←code(350B(*AOS*),0,leftside)
ELSE generate←code(370B(*SOS*),0,leftside)
END
ELSE
CASE leftside.typtr↑.form OF
scalar,
pointer,
power:
BEGIN
load(gattr);
IF (gattr.typtr=intptr) AND leftside←real THEN makereal(gattr);
store(gattr.reg,leftside)
END;
subrange:
BEGIN
cmin := leftside.typtr↑.vmin;
cmax := leftside.typtr↑.vmax;
IF leftside←real THEN
IF gattr.typtr=intptr THEN makereal(gattr);
IF gattr.kind = cst THEN WITH gattr DO
BEGIN
IF leftside←real THEN
BEGIN
IF (cval.valp↑.rval < cmin.valp↑.rval)
OR (cval.valp↑.rval > cmax.valp↑.rval) THEN error(367)
END (*LEFTSIDE←REAL*)
ELSE
IF (cval.ival < cmin.ival) OR (cval.ival > cmax.ival) THEN error (367);
load(gattr)
END (*=CST*)
ELSE
IF runtime←check AND ((gattr.kind<>varbl) OR (gattr.subkind <> leftside.typtr)) THEN
BEGIN
load(gattr);
WITH slattr DO
BEGIN
typtr:= gattr.typtr;
kind := cst;
cval := cmax
END;
generate←code(317B(*CAMG*),regc,slattr);
slattr.kind:=cst;
slattr.cval:=cmin;
generate←code(315B(*CAMGE*),regc,slattr);
support(errorinassignment)
END (*RUNTIMECHECK*)
ELSE load(gattr);
store(gattr.reg,leftside)
END;
arrays,
records:
IF gattr.typtr↑.size = 1 THEN
BEGIN
load(gattr) ; store(gattr.reg,leftside)
END
ELSE WITH leftside DO
BEGIN
load←address ;
code←array↑.instruction[cix].instr := 515B(*HRLZI*) ;
fetch←basis(leftside);
macro(vrelbyte,541B(*HRRI*),regc,indbit,indexr,dplmt);
IF indbit=0 THEN macro5(vrelbyte,251B(*BLT *),regc,indexr,dplmt+typtr↑.size-1)
ELSE
BEGIN
increment←regc ;
macro3(200B(*MOVE*),regc,regc-1);
macro4(251B(*BLT *),regc,regc-1,typtr↑.size-1)
END
END;
files:
error(361)
END (*CASE*)
%24
END (* 24.*) \
ELSE (* NOT COMPTYPES ... *)
error(260);
aos := b0
END (*SY = BECOMES*)
ELSE error(159)
END (*ASSIGNMENT*) ;
(*gotostatement,compoundstatement,ifstatement,casestatement,repeatstatement,whilestatement,forstatement,loopstatement,withstatement*)
PROCEDURE gotostatement;
VAR
lcp: ctp; lscope: levrange;
BEGIN (*GOTOSTATEMENT*)
IF counting THEN (* 28.*)
addnewcounter;
IF sy = intconst THEN
BEGIN
searchid([labels],lcp);
IF lcp <> NIL THEN
WITH lcp↑ DO
BEGIN
lscope := level - scope;
macro3r(254B(*JRST*),0,goto←chain);
goto←chain := ic-1; code←reference↑[cix] := gotoref;
IF lscope > 0 THEN
%13 (* 14.*)
IF (scope = 1) AND external THEN error(508)
ELSE (* 14.*) \
exit←jump := true
END;
insymbol
END
ELSE error(255)
END (*GOTOSTATEMENT*) ;
PROCEDURE compoundstatement;
BEGIN (*COMPOUNDSTATEMENT*)
LOOP
REPEAT
statement(fsys,statends)
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
IF sy = endsy THEN insymbol
ELSE error(163)
END (*COMPOUNDSTATEMENET*) ;
PROCEDURE ifstatement;
VAR
lcix1,lcix2: coderange;
BEGIN (*IFSTATEMENT*)
expression(fsys + [thensy],falsejmp);
lcix1 := cix;
IF sy = thensy THEN
BEGIN
insymbol;
IF counting THEN (* 28.*)
addnewcounter;
END
ELSE error(164);
statement(fsys + [elsesy],statends + [elsesy]);
IF sy = elsesy THEN
BEGIN
macro3(254B(*JRST*),0,0); lcix2 := cix;
insert←address(right,lcix1,ic);
insymbol;
IF counting THEN (* 28.*)
addnewcounter;
statement(fsys,statends);
insert←address(right,lcix2,ic)
END
ELSE insert←address(right,lcix1,ic)
END (*IFSTATEMENT*) ;
PROCEDURE casestatement;
LABEL
888,999;
TYPE
cip = ↑caseinfo;
caseinfo = PACKED
RECORD
next: cip;
csstart: addrrange;
csend: coderange;
cslab: integer
END;
VAR
lsp, lsp1: stp;
fstptr, lpt1, lpt2, lpt3, othersptr: cip;
lval: valu;
lic, laddr, jumpaddr, lmin, lmax: addrrange;
lcix: coderange;
PROCEDURE insertbound(fcix: coderange; fic: addrrange; bound: integer);
VAR
lcix1:coderange;
lic1: addrrange;
lattr:attr;
BEGIN (*INSERTBOUND*)
IF bound >= 0 THEN insert←address(no,fcix,bound)
ELSE
BEGIN
lcix1:=cix; lic1 := ic;
cix:=fcix; ic := fic;
WITH lattr DO
BEGIN
kind:=cst;
cval.ival:=bound;
typtr:=NIL
END;
deposit←constant(int,lattr);
cix:=lcix1; ic:= lic1;
WITH code←array↑.instruction[fcix] DO
instr:=instr+10B (*CAILE-->CAMLE, CAIL-->CAML*)
END
END (*INSERTBOUND*);
BEGIN (*CASESTATEMENT*)
othersptr:=NIL;
expression(fsys + [ofsy,comma,colon],onregc);
load(gattr);
macro2(301B(*CAIL*),regc); (*<<<---- LMIN IS INSERTED HERE*)
macro2(303B(*CAILE*),regc); (*<<<---- LMAX IS INSERTED HERE*)
macro2(254B(*JRST*),0); (*<<<---- START OF "OTHERS" IS INSERTED HERE*)
macro(no,254B(*JRST*),0,1,regc,0);(*<<<---- START OF JUMP TABLE IS INSERTED HERE*)
lcix := cix; lic := ic;
lsp := gattr.typtr;
IF lsp <> NIL THEN
IF (lsp↑.form <> scalar) OR (lsp = realptr) THEN
BEGIN
error(315); lsp := NIL
END;
IF sy = ofsy THEN insymbol
ELSE error(160);
(* 13. ALLOW EXTRA SEMICOLONS.*)
WHILE sy = semicolon DO
insymbol;
fstptr := NIL; lpt3 := NIL;
LOOP
LOOP
constant(fsys + [comma,colon],lsp1,lval);
IF lsp <> NIL THEN
IF comptypes(lsp,lsp1) THEN
BEGIN
lpt1 := fstptr; lpt2 := NIL;
IF abs(lval.ival) > hwcstmax THEN error(316);
WHILE lpt1 <> NIL DO
WITH lpt1↑ DO
BEGIN
IF cslab <= lval.ival THEN
BEGIN
IF cslab = lval.ival THEN error(261);
GOTO 888
END;
lpt2 := lpt1; lpt1 := next
END;
888:
new(lpt3);
WITH lpt3↑ DO
BEGIN
next := lpt1; cslab := lval.ival;
csstart := ic; csend := 0
END;
IF lpt2 = NIL THEN fstptr := lpt3
ELSE lpt2↑.next := lpt3
END
ELSE error(505)
EXIT IF sy <> comma;
insymbol
END;
IF sy = colon THEN
BEGIN
insymbol;
IF counting THEN (* 28.*)
addnewcounter;
END
ELSE error(151);
REPEAT
statement(fsys,statends)
UNTIL NOT (sy IN statbegsys);
IF lpt3 <> NIL THEN
BEGIN
macro2(254B(*JRST*),0); lpt3↑.csend := cix
END;
(* 13. ALLOW EXTRA SEMICOLONS.*)
WHILE sy = semicolon DO
insymbol;
EXIT IF sy IN (fsys + statends);
IF sy=otherssy THEN
BEGIN
insymbol;
IF sy=colon THEN insymbol
ELSE error(151);
new(othersptr);
WITH othersptr↑ DO
BEGIN
csstart:=ic;
REPEAT
statement(fsys,statends)
UNTIL NOT(sy IN statbegsys);
macro2(254B(*JRST*),0);
csend:=cix;
(* 13. ALLOW EXTRA SEMICOLONS *)
WHILE sy = semicolon DO
insymbol;
GOTO 999
END
END
END;
999:
IF fstptr <> NIL THEN
BEGIN
lmax := fstptr↑.cslab;
(*REVERSE POINTERS*)
lpt1 := fstptr; fstptr := NIL;
REPEAT
lpt2 := lpt1↑.next; lpt1↑.next := fstptr;
fstptr := lpt1; lpt1 := lpt2
UNTIL lpt1 = NIL;
lmin := fstptr↑.cslab;
insertbound(lcix-2,lic-2,lmax);
insertbound(lcix-3,lic-3,lmin);
insert←address(right,lcix,ic-lmin);
IF (lmax - lmin) < (code←size - cix) THEN
BEGIN
laddr := ic + lmax - lmin + 1;
IF othersptr = NIL THEN jumpaddr := laddr
ELSE
BEGIN
insert←address(right,othersptr↑.csend,laddr);
jumpaddr:=othersptr↑.csstart
END;
insert←address(right,lcix-1,jumpaddr);
REPEAT
WITH fstptr↑ DO
BEGIN
WHILE cslab > lmin DO
BEGIN
generate←word(right,0,jumpaddr); lmin := lmin + 1
END;
generate←word(right,0,csstart);
IF csend <> 0 THEN insert←address(right,csend,laddr);
fstptr := next; lmin := lmin + 1
END
UNTIL fstptr = NIL
END
ELSE
BEGIN
IF NOT overrun THEN
BEGIN
overrun := true;
IF fprocp = NIL THEN error←with←text(356,'MAIN ')
ELSE error←with←text(356,fprocp↑.name)
END;
cix := 0
END
END;
IF sy = endsy THEN insymbol
ELSE error(163)
END (*CASESTATEMENT*) ;
PROCEDURE repeatstatement;
VAR
laddr: addrrange;
BEGIN (*REPEATSTATEMENT*)
laddr := ic;
IF counting THEN (* 28.*)
entercount := true;
LOOP
REPEAT
statement(fsys + [untilsy],statends + [untilsy])
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
IF sy = untilsy THEN
BEGIN
insymbol; expression(fsys,falsejmp); insert←address(right,cix,laddr)
END
ELSE error(202)
END (*REPEATSTATEMENT*) ;
PROCEDURE whilestatement;
VAR
laddr: addrrange;
lcix: coderange;
BEGIN (*WHILESTATEMENT*)
laddr := ic;
expression(fsys + [dosy],falsejmp);
lcix := cix;
IF sy = dosy THEN
BEGIN (* 28.*)
insymbol;
IF counting THEN
entercount := true;
END
ELSE error(161);
statement(fsys,statends);
macro3r(254B(*JRST*),0,laddr);
insert←address(right,lcix,ic)
END (*WHILESTATEMENT*) ;
PROCEDURE forstatement;
VAR
lattr: attr;
lsp: stp;
lsy: symbol;
lcix: coderange;
laddr,ldplmt: addrrange;
linstr: instrange;
lregc,lindreg: acrange;
lindbit: ibrange;
lrelbyte: relbyte;
addtolc: addrrange;
BEGIN (*FORSTATEMENT*)
IF sy = ident THEN
BEGIN
searchid([vars],lcp);
WITH lcp↑, lattr DO
BEGIN
typtr := idtype; kind := varbl;
IF vkind = actual THEN
BEGIN
vlevel := vlev;
IF vlev > 1 THEN vrelbyte := no
ELSE vrelbyte := right;
dplmt := vaddr; indexr :=0; packfg := notpack;
indbit:=0
END
ELSE
BEGIN
error(364); typtr := NIL
END
END;
IF lattr.typtr <> NIL THEN
IF comptypes(realptr,lattr.typtr) OR (lattr.typtr↑.form > subrange) THEN
BEGIN
error(365); lattr.typtr := NIL
END;
insymbol
END
ELSE
BEGIN
errandskip(209,fsys + [becomes,tosy,downtosy,dosy]);
lattr.typtr := NIL
END;
IF sy = becomes THEN
BEGIN
insymbol; expression(fsys + [tosy,downtosy,dosy],onregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN error(315)
ELSE
IF comptypes(lattr.typtr,gattr.typtr) THEN load(gattr)
ELSE error(556);
lregc := gattr.reg
END
ELSE errandskip(159,fsys + [tosy,downtosy,dosy]);
IF sy IN [tosy,downtosy] THEN
BEGIN
lsy := sy; insymbol; expression(fsys + [dosy],onregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN error(315)
ELSE
IF comptypes(lattr.typtr,gattr.typtr) THEN
BEGIN
addtolc := 0 ;
WITH gattr DO
IF ((kind = varbl) AND
(((vlevel > 1) AND (vlevel < level)) OR
(packfg <> notpack) OR
((indexr > 0) AND (indexr <= regcmax)))) OR
(kind = expr) THEN
BEGIN
load(gattr); macro4(202B(*MOVEM*),regc,basis,lc); addtolc := 1;
kind := varbl ; indbit := 0 ; indexr := basis ; vlevel := 1;
dplmt := lc ; packfg := notpack ; vrelbyte := no
END ;
fetch←basis(lattr);
WITH lattr DO
BEGIN
IF (indexr>0) AND (indexr<=regcmax) THEN
BEGIN
macro(no,551B(*HRRZI*),indexr,indbit,indexr,dplmt);
lindbit := 1; ldplmt := lc+addtolc; lindreg := basis ;
macro4(202B(*MOVEM*),indexr,basis,ldplmt);
addtolc := addtolc + 1
END
ELSE
BEGIN
lindbit := indbit; lindreg := indexr; ldplmt := dplmt
END;
lrelbyte:= vrelbyte
END;
macro(lrelbyte,202B(*MOVEM*),lregc,lindbit,lindreg,ldplmt);
IF lsy = tosy THEN linstr := 313B(*CAMLE*)
ELSE linstr := 315B(*CAMGE*);
laddr := ic;
generate←code(linstr,lregc,gattr)
END
ELSE error(556)
END
ELSE errandskip(251,fsys + [dosy]);
macro3(254B(*JRST*),0,0); lcix :=cix;
IF sy = dosy THEN
BEGIN (* 28.*)
insymbol;
IF counting THEN
entercount := true;
END
ELSE error(161);
lc := lc + addtolc;
IF lc > lcmax THEN lcmax:=lc;
statement(fsys,statends);
lc := lc - addtolc;
IF lsy = tosy THEN linstr := 350B(*AOS*)
ELSE linstr := 370B(*SOS*);
macro(lrelbyte,linstr,lregc,lindbit,lindreg,ldplmt);
macro3r(254B(*JRST*),0,laddr); insert←address(right,lcix,ic)
END (*FORSTATEMENT*) ;
PROCEDURE loopstatement;
VAR
laddr: addrrange;
lcix: coderange;
BEGIN (*LOOPSTATEMENT*)
laddr := ic;
IF counting THEN (* 28.*)
addnewcounter;
LOOP
REPEAT
statement(fsys + [exitsy],statends + [exitsy])
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
IF sy = exitsy THEN
BEGIN
insymbol;
IF sy = ifsy THEN
BEGIN
insymbol; expression(fsys + [semicolon,endsy],truejmp)
END
ELSE errandskip(162,fsys + [semicolon,endsy]);
lcix := cix;
statement(fsys,statends); (* 28.*)
IF counting THEN
entercount := true;
LOOP
WHILE (sy IN statbegsys) DO (* 28.*)
statement(fsys,statends)
EXIT IF sy <> semicolon;
insymbol;
statement(fsys,statends);
END;
macro3r(254B(*JRST*),0,laddr); insert←address(right,lcix,ic)
END
ELSE error(165);
IF sy = endsy THEN insymbol
ELSE error(163)
END (*LOOPSTATEMENT*) ;
PROCEDURE withstatement;
VAR
lcp: ctp; oldlc: addrrange; lcnt1: disprange; oldregc: acrange;
BEGIN (*WITHSTATEMENT*)
lcnt1 := 0; oldregc := regcmax; oldlc := lc;
LOOP
IF sy = ident THEN
BEGIN
searchid([vars,field],lcp); insymbol
END
ELSE
BEGIN
error(209); lcp := uvarptr
END;
selector(fsys + [comma,dosy],lcp);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form = records THEN
IF top < displimit THEN
BEGIN
top := top + 1; lcnt1 := lcnt1 + 1; withix := withix + 1;
WITH display[top], gattr DO
BEGIN
fname := typtr↑.fstfld;
occur := crec;
IF indbit = 1 THEN get←parameter←address;
fetch←basis(gattr);
IF (indexr<>0) AND (indexr <> basis) THEN
BEGIN
macro3(550B(*HRRZ*),regcmax,indexr);
indexr := regcmax;
regcmax := regcmax-1;
IF regcmax<regc THEN
BEGIN
error(317);
regc := regcmax
END
END;
clev := vlevel; crelbyte := vrelbyte;
cindr := indexr; cindb:=indbit;
cdspl := dplmt;
clc := lc;
IF (cindr<>0) AND (cindr<>basis) THEN
BEGIN
lc := lc + 1;
IF lc>lcmax THEN lcmax := lc
END
END
END
ELSE error(404)
ELSE error(308)
EXIT IF sy <> comma;
insymbol
END;
IF sy = dosy THEN insymbol
ELSE error(161);
statement(fsys,statends);
regcmax:=oldregc;
top := top - lcnt1; lc := oldlc; withix := withix - lcnt1
END (*WITHSTATEMENT*) ;
(* ]STATEMENT ]BODY ]BLOCK *)
BEGIN (*STATEMENT*)
IF sy = intconst THEN (*LABEL*)
BEGIN
searchid([labels],lcp);
IF lcp <> NIL THEN
WITH lcp↑ DO
BEGIN
IF label←address = 0 THEN
BEGIN
IF exit←jump THEN macro3r(324B(*JUMPA*),reg0,ic+3);
label←address := ic;
IF exit←jump THEN
BEGIN
macro3r(200B(*MOVE*),basis,jump←table[jump←index]); code←reference↑[cix] := saveref;
macro3r(200B(*MOVE*),topp,jump←table[jump←index] + 1); code←reference↑[cix] := saveref;
jump←table[jump←index] := label←address
END
END
ELSE error(211);
IF scope <> level THEN error(352)
END;
insymbol;
IF sy = colon THEN
BEGIN (* 28.*)
insymbol;
IF counting THEN
BEGIN
addnewcounter; entercount := false;
END;
END
ELSE error(151)
END (* OF LABEL *);
IF NOT (sy IN fsys + [ident]) THEN errandskip(166,fsys);
IF sy IN statbegsys + [ident] THEN
IF initglobals (* INSIDE AN INITPROCEDURE *) THEN
IF sy <> ident THEN error(462)
ELSE
BEGIN
searchid([vars,field,func,proc],lcp); insymbol;
IF lcp↑.klass = proc THEN error(462)
ELSE assignment(lcp);
%24 regc := regin; (* 24.*) \
END
ELSE (*...NOT INITGLOBALS*)
BEGIN
IF entercount THEN
BEGIN (* 28.*)
addnewcounter; entercount := false;
END;
IF debug←switch THEN put←linenumber;
regc := regin;
CASE sy OF
ident:
BEGIN
searchid([vars,field,func,proc],lcp); insymbol;
WITH lcp↑ DO
IF (klass = vars) AND (vlev = 0) AND (sy = arrow) AND
(idtype↑.form = files) AND (name = 'TTY ') THEN
BEGIN
id := 'TTYOUTPUT '; searchid([vars],lcp)
END;
IF lcp↑.klass = proc THEN profuncall(fsys,lcp)
ELSE assignment(lcp)
END;
beginsy:
BEGIN
insymbol; compoundstatement
END;
gotosy:
BEGIN
insymbol; gotostatement
END;
ifsy:
BEGIN
insymbol; ifstatement
END;
casesy:
BEGIN
insymbol; casestatement
END;
whilesy:
BEGIN
insymbol; whilestatement
END;
repeatsy:
BEGIN
insymbol; repeatstatement
END;
loopsy:
BEGIN
insymbol; loopstatement
END;
forsy:
BEGIN
insymbol; forstatement
END;
withsy:
BEGIN
insymbol; withstatement
END
END (*CASE*) ;
(* RE-INITIALIZE REGISTER COUNTER TO AVOID OVERFLOW DURING SUBSEQUENT
EXPRESSION EVALUATIONS IN REPEATSTATEMENT OR LOOPSTATEMENT *)
regc := regin
END (*..NOT INITGLOBALS*);
skipiferr(statends,506,fsys)
END (*STATEMENT*) ;
BEGIN
(*BODY*)
regcmax:=within; withix := -1; firstkonst := NIL;
reg2←saved := false;
%13 (* 18.*)
IF NOT entry←done THEN
BEGIN
entry←done:= true;
write←machine←code(write←entry);
write←machine←code(write←name);
write←machine←code(write←hiseg)
END;
(* 18.*) \
cix := -1 ;
%13 (* 24.*)
IF initglobals THEN (* INSIDE AN INITPROCEDURE IN PASCAL*)
BEGIN
cglobptr := NIL ;
LOOP
IF sy <> endsy THEN statement([semicolon,endsy],[semicolon,endsy])
EXIT IF sy <> semicolon ;
insymbol
END ;
IF sy = endsy THEN insymbol
ELSE error(163) ;
write←machine←code(write←globals)
END
ELSE (* NOT INITGLOBALS *)
(* 24.*) \
BEGIN
enterbody;
IF fprocp <> NIL THEN
%24 (* 24.*)
BEGIN
IF initglobals THEN
initpraddr[initproccount] := pfstart;
(* 24.*) \
fprocp↑.pfaddr:= pfstart
%24 END \
ELSE
%24 (* 24.*)
BEGIN
FOR i := 0 TO initproccount DO
macro3r(260B(*PUSHJ*),topp,initpraddr[i]);
(* 24.*) \
lc:= 1;
%24 END;
\
lcmax:=lc;
LOOP
REPEAT
statement(fsys + [semicolon,endsy],[semicolon,endsy])
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
IF sy = endsy THEN insymbol
ELSE error(163);
leavebody;
insert←address(no,stacksize1,lcmax);
insert←address(no,stacksize2,lcmax);
write←machine←code(write←code);
IF debug THEN write←machine←code(write←debug);
write←machine←code(write←internals);
IF level = 1 THEN
BEGIN
write←machine←code(write←fileblocks);
%13 (* 18.*)
write←machine←code(write←counters); (* 28.*)
write←machine←code(write←symbols);
write←machine←code(write←library);
write←machine←code(write←start);
write←machine←code(write←end)
(* 18.*) \
END
END
END (*BODY*) ;
BEGIN (*BLOCK*)
new(heapmark);
dp := true; testpacked := false; forward←procedures := NIL; current←jump := 0;
IF genprocfile THEN
BEGIN
firstline := headline;
beginline := 0;
END;
REPEAT
WHILE sy IN blockbegsys - [beginsy] DO
BEGIN
IF sy = labelsy THEN
BEGIN
insymbol; labeldeclaration
END;
IF sy = constsy THEN
BEGIN
insymbol; constantdeclaration
END;
IF sy = typesy THEN
BEGIN
insymbol; typedeclaration
END;
lcpar := lc;
IF sy = varsy THEN
BEGIN
insymbol; variabledeclaration
END;
IF (level > 1) AND (sy = initprocsy) THEN errandskip(363,blockbegsys - [initprocsy]);
IF level = 1 THEN
BEGIN
IF lc > maxruncore * 1024 THEN
error←valued(470,lc);
WHILE sy = initprocsy DO
BEGIN
IF genprocfile THEN
BEGIN
headline := linecnt; beginline := 0;
END;
%13 (* 24.*)
insymbol ;
IF sy <> semicolon THEN errandskip(156,[beginsy])
ELSE insymbol ;
IF sy = beginsy THEN
BEGIN
new(globmark); initglobals := true ;
IF genprocfile THEN
beginline := linecnt;
insymbol ; body(fsys + [semicolon,endsy]) ;
IF genprocfile THEN
writeln(procfile,' INITPROCED',headline:6,beginline:6,linecnt:6);
IF sy = semicolon THEN insymbol
ELSE error(166) ;
initglobals := false; dispose(globmark)
END
ELSE error(201)
(* 24.*) \
%24 (* 24.*)
initglobals := true;
IF initproccount = 99 THEN
error(413)
ELSE
BEGIN
sy := ident;
id := '.INITPRO ';
initproccount := initproccount + 1;
id[ 9] := chr(initproccount DIV 10 + ord('0'));
id[10] := chr(initproccount MOD 10 + ord('0'));
END;
proceduredeclaration(true);
initglobals := false;
(* 24.*) \
END ;
lcmain := lc; testpacked := false;
IF counting THEN
BEGIN (* 28.*)
counter := 1; startofcounts := lcmain;
%13 lastlcmain := lcmain; \
%24
new(firstcntp);
firstcntp↑.next := NIL;
lastcntp := firstcntp;
\
END;
END;
WHILE sy IN [proceduresy,functionsy] DO
BEGIN
lsy := sy; insymbol; proceduredeclaration(lsy=proceduresy)
END;
WHILE forward←procedures <> NIL DO
WITH forward←procedures↑ DO
BEGIN
IF forwdecl THEN error←with←text(465,name);
forward←procedures := testfwdptr
END;
skipiferr([beginsy],201,fsys)
END;
dp := false;
IF sy = beginsy THEN
BEGIN
IF genprocfile THEN
beginline := linecnt;
insymbol;
IF counting THEN (* 28.*)
entercount := true;
END
ELSE error (201);
body(fsys + [casesy]);
skipiferr(leaveblocksys,166,fsys)
UNTIL sy IN leaveblocksys;
IF genprocfile THEN
BEGIN
writeln(procfile,' ':(level-1)*4,currname,firstline:6,beginline:6,linecnt:6);
END;
dispose(heapmark)
END (*BLOCK*) ;
(* ]compile,reporttime,jumpto *)
BEGIN (* COMPILE *)
writeln(tty);
%13 write(tty, header:headlen, ': ',object←file:6); (* 14.*) \
%24 write (tty, header:headlen, ': ', source←file:6); (* 15.*) \
break(tty);
(* 6. KEEP FIRST PAGE FOR TTY MESSAGES.*)
firstpage := pagecnt;
error←in←heading := true;
getnextline; ch := ' '; insymbol; reset←possible := false;
new( code←array, pdp10code: code←size );
new( code←reference: code←size );
new( code←relocation: code←size );
%13 (* 14.*)
IF external THEN
BEGIN
lc := low←start; lcmain := lc;
WHILE sfileptr <> NIL DO
WITH sfileptr↑, fileident↑ DO
BEGIN
vaddr := 0; sfileptr := nextftp
END;
sfileptr := fileptr
END;
(* 14.*) \
IF sy = programsy THEN
BEGIN
IF genprocfile THEN
BEGIN
headline := linecnt;
procname←file := source←file;
procname←file[7] := 'P';
procname←file[8] := 'R';
procname←file[9] := 'C';
rewrite(procfile,procname←file);
writeln(procfile,header,' PROC/FUNC LINE NUMBER REPORT OF ',
source←file:6,'.',source←file[7],source←file[8],source←file[9],' ON ',day,' AT ',timeofday);
writeln(procfile);
writeln(procfile,'PROC/FUNC HEAD BEGIN END');
writeln(procfile);
END;
insymbol;
IF sy = ident THEN
BEGIN
programname := id; escape := false;
currname := id;
WHILE (entries < entrymax) AND (sy = ident) AND NOT escape DO
BEGIN
entries := entries + 1;
entry[ entries ] := id;
insymbol;
IF sy = comma THEN
BEGIN
insymbol;
IF sy <> ident THEN
BEGIN
escape := true; error(209)
END
END
ELSE
IF NOT (sy IN [semicolon,lparent]) THEN
BEGIN
escape := true; error(156)
END
END;
IF sy = lparent THEN
BEGIN
REPEAT
insymbol;
IF sy = ident THEN
BEGIN
new(lparmptr);
IF parmptr = NIL THEN parmptr := lparmptr;
WITH lparmptr↑ DO
BEGIN
fileid := id; fileidptr := NIL;
FOR i := 1 TO 2 DO
IF fileid = na[stdfile,i] THEN
BEGIN
fileidptr := stdfileptr[i];
IF i = 1 THEN
inputpar := true
ELSE
outputpar := true;
END;
nextptp := NIL;
IF backwparmptr <> NIL THEN backwparmptr↑.nextptp := lparmptr;
backwparmptr := lparmptr; insymbol;
IF (sy IN [mulop,addop]) AND (op IN [mul,plus]) THEN
BEGIN
IF op = plus THEN error(169);
inputfile := true; insymbol
END
END
END
ELSE (*SY <> IDENT*)
error(209)
UNTIL sy <> comma;
IF sy <> rparent THEN errandskip(152,blockbegsys)
ELSE
BEGIN
insymbol;
skipiferr([semicolon],156,blockbegsys)
END
END
ELSE (*SY <> LPARENT*)
skipiferr([semicolon],156,blockbegsys)
END
ELSE (*SY <> IDENT*)
errandskip(209,blockbegsys)
END
ELSE (*SY <> PROGRAMSY*)
errandskip(318,blockbegsys);
IF sy = semicolon THEN insymbol;
IF NOT error←flag THEN
BEGIN
if logfile then
begin
writeln(list,header,' compilation log produced on ',day,' at ',timeofday);
writeln(list,source←file:6,': [',programname,' ]');
writeln(list);
end;
write(tty, ' [ ', programname);
%13 (* 14.*)
IF (entries > 1) AND external THEN
BEGIN
write(tty,': '); i := 2;
LOOP
write(tty,entry[i])
EXIT IF i >= entries;
i := i + 1;
write(tty,', ')
END
END;
(* 14.*) \
(* 6. GIVE PAGE NUMBERS ON TTY.*)
write (tty, ' ] PAGE');
FOR i := firstpage TO pagecnt DO
write (tty, i:3,'..');
break(tty);
%24 error←in←heading := true; (* 14.*) \
END;
block(NIL,blockbegsys + statbegsys-[casesy],[period,colon]);
error←exit := true; finishline;
111:
IF lptfile or logfile THEN
BEGIN
writeln(list);
writeln(list,errorcount:4,' ERROR(S) DETECTED');
writeln(list)
END;
writeln(tty);
writeln(tty,errorcount:4,' ERROR(S) DETECTED');
IF error←flag THEN (* 13.*)
no←code←gen := true
%13 (* 14.*)
ELSE
BEGIN
core[1] := highest←code-high←start; core[2] := core[1] MOD 1024;
core[1] := core[1] DIV 1024;
IF lptfile or logfile THEN
writeln(list,'HIGHSEG: ',core[1]:3,'K + ',core[2]:4,' WORD(S)');
writeln(tty,'HIGHSEG: ',core[1]:3,'K + ',core[2]:4,' WORD(S)');
core[1] := lcmain DIV 1024; core[2] := lcmain MOD 1024;
IF lptfile or logfile THEN
BEGIN
writeln(list,'LOWSEG : ',core[1]:3,'K + ',core[2]:4,' WORD(S)'); writeln(list)
END;
writeln(tty,'LOWSEG : ',core[1]:3,'K + ',core[2]:4,' WORD(S)');
END (* 14.*) \ ;
dispose( code←array, pdp10code: code←size )
END (* COMPILE *);
PROCEDURE reporttime; (* 22. USE THE LIBRARY PROCEDURES*)
VAR
rtime, elapstime: alfa;
BEGIN (* REPORTTIME *)
runtime(rtime);
elapsedtime (elapstime);
IF lptfile or logfile THEN
BEGIN
writeln(list);
%24 write (list,' COMPILE '); (* 18.*) \
write(list,'RUNTIME: ',rtime,' ':5,'ELAPSED: ',elapstime,tchcnt:10,' chars');
END;
writeln(tty);
%24 write (tty, ' COMPILE '); (* 18.*) \
write(tty,'RUNTIME: ',rtime,' ':5,'ELAPSED: ',elapstime,tchcnt:10,' chars');
break(tty);
END (* REPORTTIME *);
%24 (* 15. NEEDED BY PASSGO TO JUMP TO THE USER CODE.*)
PROCEDURE jumpto (startpoint, datastart, debugdata,stacktop: addrrange;
progname: integer);
EXTERN;
(* 15.*) \
(* MAIN BODY *)
BEGIN (*PASCAL*)
settime; (* 22.*)
date(day); time(timeofday);
init←compile;
%24 initpassgo; (* 15. INITIALIZE ADDRESSES OF EXTERNALS.*) \
(*ENTER STANDARD NAMES AND STANDARD TYPES:*)
(******************************************)
level := 0; top := 0;
WITH display[0] DO
BEGIN
fname := NIL; occur := blck
END;
enterstdtypes; enterstdnames; enterundecl;
top := 1; level := 1;
WITH display[1] DO
BEGIN
fname := NIL; occur := blck
END;
get←directives;
%13 (* 14. PASCAL VERSION OF THE ACTUAL COMPILING PROCESS.*)
IF NOT option('NOCOMPILE ') THEN
BEGIN
IF lptfile THEN
BEGIN
writeln(list,header,' COMPILATION LIST PRODUCED ON ',
day,' AT ',timeofday,' PAGE 1'); writeln(list)
END;
LOOP
compile
EXIT IF NOT external OR eof(source);
init←compile
END;
END (* IF NOT OPTION('NOCOMPILE ') *);
0:
reporttime;
IF NOT no←code←gen THEN (* 13. ERRORS OF ALL THE FILE, NOT ONLY THE LAST MODULE*)
BEGIN
IF cross←reference OR counting THEN
BEGIN
(* 14. NO LPTFILE IF CROSS←REFERENCE*)
rewrite(tempcore,pcross←tmpfile);
i := 1;
WHILE i <= 6 DO
IF source←device[i] = ' ' THEN
i := 7
ELSE
BEGIN
write(tempcore,source←device[i]);
i := i + 1;
END;
write(tempcore,':',source←file:6, '.' ,
source←file[7],source←file[8],source←file[9], ',' ,
source←file:6,'.NEW,',source←file:6,'.lst');
FOR i := 1 TO maxpcrossoption DO
IF option (pcross←option←name [i]) THEN
BEGIN
write (tempcore, '/',pcross←option←name [i]);
getoption (pcross←option←name [i], j);
IF j <> 0 THEN
write (tempcore, ':', j:3);
END;
IF NOT counting THEN
BEGIN
(* 1., 4. PASS THE LINKER NAME TO PCROSS.*)
IF loadit THEN
BEGIN
writeln (tempcore);
FOR i := 1 TO 6 DO
IF link←device [i] = ' ' THEN
i := 7
ELSE
write (tempcore, link←device [i]);
write(tempcore,':');
FOR i := 1 TO 6 DO
IF linker←file [i] = ' ' THEN
i := 7
ELSE
write (tempcore, linker←file[i]);
writeln (tempcore,'!');
END;
call(pcross←file,pcross←device,pcross←ppn,pcross←core); (* 4.*)
END;
END;
IF loadit THEN
BEGIN
writeln(tty); break(tty);
call(linker←file,link←device) (* 1.*)
END
END
ELSE
BEGIN
rewrite(object);
rewrite(tempcore,link←tmpfile);
writeln(tty);
writeln(tty,'EXECUTION SUPPRESSED');
END;
\
%1
write (tty,bel);
(* 14. END OF THE PASCAL VERSION OF THE ACTUAL COMPILING PROCESS.*) \
%24 (* 15. PASSGO VERSION OF THE ACTUAL COMPILING AND EXECUTING PROCESS.*)
IF lptfile THEN
BEGIN
writeln (list,header,' COMPILATION LIST PRODUCED ON '
,day,' AT ', timeofday,' PAGE 1'); writeln(list);
END;
(* 26. SHOW RUNTIME MAPPING.*)
IF option('SHOW ') THEN
BEGIN
writeln(tty,'RUNTIME PROCEDURES: ');
FOR i := 1 TO namax[declproc] DO
writeln(tty,na[declproc,i],': ',extaddr[declproc,i]:6:o);
writeln(tty);
writeln(tty,'PREDEFINED FUNCTIONS:');
FOR i := 1 TO namax[declfunc] DO
writeln(tty,na[declfunc,i],': ',extaddr[declfunc,i]:6:o);
writeln(tty);
writeln(tty,'RUNTIMES:');
FOR suptindex := first(suptindex) TO last(suptindex) DO
writeln(tty,runtime←support.name[suptindex]:7,': ',runtime←support.link[suptindex]:6:o);
END;
compile;
0:
IF NOT no←code←gen THEN
BEGIN
(* 26. SHOW MEMORY ORGANIZATION.*)
IF option('SHOW ') THEN
BEGIN
writeln(tty,'USER PROGRAM ARRAY SIZE: ',maxcode:6:o,'B');
writeln(tty,'FILE DATA START : ',userareastart:6:o,'B');
writeln(tty,' END : ',filelc:6:o,'B');
writeln(tty,'CODE START : ',userareastart+maxfilecode:6:o,'B');
writeln(tty,' END : ',ic:6:o,'B');
writeln(tty,' ENTRY POINT : ',start←address:6:o,'B');
writeln(tty,'DATA START : ',datastart:6:o,'B');
writeln(tty,' END : ',lcmain:6:o,'B');
rewrite(object,'OBJECTREL'); (* PSEUDO REL FILE FOR DEBUGGING *)
WITH userprog DO
BEGIN
WITH change DO (* START ADDRESS BLOCK *)
BEGIN
wlefthalf := 7;
wrighthalf := 1;
object↑ := wkonst;
put(object);
object↑ := 0;
put(object);
object↑ := start←address;
put(object);
END;
i := maxfilecode;
WHILE (i + userareastart) < highest←code DO (* CODE BLOCKS*)
BEGIN
WITH change DO (* HEADER: BLOCK TYPE AND SIZE *)
BEGIN
wlefthalf := 1;
wrighthalf := 22B;
object↑ := wkonst;
put(object);
END;
object↑ := 0; (* RELOCATION WORD AND ADDRESS *)
put(object);
object↑ := userareastart + i;
put(object);
FOR j := i TO i + 20B DO (* CODE *)
BEGIN
IF (j + userareastart) < highest←code THEN
object↑ := execode[j]
ELSE
object↑ := 377777777777B;
put(object);
END;
i := i + 21B;
END;
i := 0; (* FILE DESCRIPTOR BLOCKS *)
WHILE (i + userareastart) < filelc DO
BEGIN
WITH change DO (* HEADER: BLOCK TYPE AND SIZE *)
BEGIN
wlefthalf := 1;
wrighthalf := 22B;
object↑ := wkonst;
put(object);
END;
object↑ := 0; (* RELOCATION WORD AND ADDRESS *)
put(object);
object↑ := userareastart + i;
put(object);
FOR j := i TO i + 20B DO (* DATA *)
BEGIN
IF (j + userareastart) < filelc THEN
object↑ := execode [j]
ELSE
object↑ := 377777777777B;
put(object);
END;
i := i+21B;
END;
reset(object);
END;
END;
IF cross←reference THEN
BEGIN
rewrite(tempcore,pcross←tmpfile);
i := 1;
WHILE i <= 6 DO
IF source←device[i] = ' ' THEN
i := 7
ELSE
BEGIN
write(tempcore,source←device[i]);
i := i + 1;
END;
write(tempcore,':');
write(tempcore,source←file:6, '.' ,
source←file[7],source←file[8],source←file[9], ',' ,
source←file:6,'.NEW,',source←file:6,'.lst');
FOR i := 1 TO maxpcrossoption DO
IF option (pcross←option←name [i]) THEN
BEGIN
write (tempcore, '/',pcross←option←name [i]);
getoption (pcross←option←name [i], j);
IF j <> 0 THEN
write (tempcore, ':', j:3);
END;
writeln (tempcore);
reset (tempcore);
END;
IF genprocfile THEN
reset(procfile);
FOR i := 1 TO 6 DO
change.wsixbit[i] := ord(programname[i]) - 40B;
reenter;
reporttime;
IF lptfile AND NOT cross←reference THEN
reset(list);
writeln(tty);
writeln(tty,programname,': EXECUTION');
break(tty);
jumpto (start←address, datastart, userareastart + debug←save, lcmain + 2,change.wkonst);
END
ELSE
BEGIN
reporttime;
IF lptfile THEN
BEGIN
writeln(list); writeln(list,'EXECUTION SUPPRESSED.');
END;
writeln(tty); writeln(tty,'EXECUTION SUPPRESSED.' \ %2 ,bel \ %24 );
END;
(* 15. END OF PASSGO VERSION OF THE ACTUAL COMPILE AND EXECUTING PROCESS.*) \
END (*PASCAL*).